1

I have an Excel worksheet called "Main" which includes a set amount of columns, one of which contains a listing of different codes (CVE's) regarding patches that need to be installed on worksheets based on criteria from the internet.

The codes to search for are not in a set format, other than being in strings containing the code.

I manually created a number of worksheets based on keywords in these strings, that will eventually, contain all the lines from the master sheet, but only those defined by the name of the keyword I want.

For example, I have a worksheet named "Microsoft" that should contain all the rows from the master sheet that refer to Microsoft CVE's, based on a search of the string and finding the word "Microsoft". Same for Adobe and so on.

I created a script to copy the rows, as well as create a new Index sheet that lists the amount of rows found for each keyword that have been copied from the master sheet to the relevant sheet.

And this is where I get lost.

I have 18 worksheets which are also keywords. I can define a single keyword and then copy everything over from the main worksheet for one keyword.

I need a loop (probably a loop within a loop) that reads the worksheet names as defined in the Index, searches for all the relevant rows that contain a CVE regarding that keyword, and then copy the row over to the relevant worksheet that I created into the relevant row on that worksheet.
For example, if I have copied two rows, the next one should be written to the next row and so on, until I have looped through all the worksheet (keyword) names and have reached the empty row after the last name in the Index sheet.

My code, set for only one keyword for a limited run to test works.
I need to loop through all the keywords and copy all the data.
In the end, I want to copy the relevant row from the master worksheet (Main) to the relevant worksheet (based on keyword worksheet name in the Index worksheet), and delete the row after it was copied from the master worksheet.
I should end up with all the data split into the relevant worksheets and an empty (except for headers) master worksheet.

This is what I have so far (from various examples and my own stuff).

Public WSNames() As String
Public WSNum() As Long
Public I As Long
Public ShtCount As Long

Sub MoveBasedOnValue()

    Dim CVETitle As String
    
    Dim xRg As Range
    Dim xCell As Range

    Dim A As Long
    Dim B As Long
    Dim C As Long
    Dim D As Long
    Dim CountCop As Long
   
    A = Worksheets("Main").UsedRange.Rows.Count
    A = A + 1
    
    'Create an index of the worksheet names to work with for moving the data and counting the lines in the WS
    ReadWSNames
    
    B = Worksheets(WSNames(2)).UsedRange.Rows.Count
    B = B + 1 'Place under the last row for start

    'Range to read and scan from
    Set xRg = Worksheets("Main").Range("E5:E" & A)

    On Error Resume Next
    Application.ScreenUpdating = False
    
    'For C = 1 To xRg.Count
    For C = 1 To 5
    
       'Read in the string to search from the Main WS
        CVETitle = CStr(xRg(C).Value)
    
       'Find if the word we want exists in the string
        If InStr(1, CVETitle, WSNames(2)) > 0 Then
            xRg(C).EntireRow.Copy Destination:=Worksheets(WSNames(2)).Range("A" & B + 1)
            CountCop = Worksheets("Index").Range("B3").Value
            CountCop = CountCop + 1
            Worksheets("Index").Range("B3").Value = CountCop
            'xRg(C).EntireRow.Delete
            'If CStr(xRg(C).Value) = WSNames(2) Then
            'C = C - 1
        'End If

            B = B + 1

        End If

    Next

    Application.ScreenUpdating = True

End Sub


Sub ReadWSNames()

    ReDim WSNames(1 To ActiveWorkbook.Sheets.Count)
    ReDim WSNum(1 To ActiveWorkbook.Sheets.Count)
    
    Dim MyIndex As Worksheet
    
    ShtCount = Sheets.Count

   'Read sheetnames and number of lines in each WS into arrays and clear the sheets other than the main one
    If Not IndexExists("Index") Then
        For I = 1 To ShtCount
            WSNames(I) = Sheets(I).Name
            If WSNames(I) <> "Main" Then ActiveWorkbook.Worksheets(WSNames(I)).Range("5:10000").EntireRow.Delete
            WSNum(I) = Worksheets(WSNames(I)).UsedRange.Rows.Count
            WSNum(I) = WSNum(I) - 3
        Next I
        'Add an index worksheet before the main worksheet and make sure one doesn't exist
        Worksheets.Add Before:=Worksheets(1)
        ActiveSheet.Name = "Index" 'Give new Ws a name
        Application.DefaultSheetDirection = xlLTR 'Make direction suited to English
        'Write headers and set parameters
        Range("A1").Value = "WS Names"
        Range("B1").Value = "Count"
        With Range("A1:B1")
            .Font.Size = 14
            .Font.Bold = True
            .Font.Color = vbBlue
        End With
        Columns("A:B").AutoFit
        Columns("B:B").HorizontalAlignment = xlCenter
        'Write data from arrays into Index WS
        ActiveCell.Offset(1, 0).Select
        For I = 1 To ShtCount 'Write values to Index WS
            ActiveCell.Value = WSNames(I) 'Write Worksheet name
            ActiveCell.Offset(0, 1) = WSNum(I) 'Write number of rows already existing in Ws
            ActiveCell.Offset(1, 0).Select 'Move one cell down
        Next I
        Worksheets("Index").Activate 'Make Index the active ws
        Range("A2").Select 'Select first cell to read data from
        I = 1
        X = 2
        Do While Not IsEmpty(Range("A" & X)) 'Read values back into array to make sure i's all there
            WSNames(I) = ActiveCell.Value
            WSNum(I) = ActiveCell.Offset(0, 1).Value
            ActiveCell.Offset(1, 0).Select 'Move one cell down
            I = I + 1
            X = X + 1
        Loop
        Worksheets("Main").Activate 'Make Main the active ws
    Else 'If Index exists, simply read the data into the arrays
        Worksheets("Index").Activate 'Make Index the active ws
        Range("A2").Select 'Select first cell to read data from
        I = 1
        X = 2
        Do While Not IsEmpty(Range("A" & X)) 'Read values back into array to make sure i's all there
            WSNames(I) = ActiveCell.Value
            WSNum(I) = ActiveCell.Offset(0, 1).Value
            ActiveCell.Offset(1, 0).Select 'Move one cell down
            I = I + 1
            X = X + 1
        Loop
        Worksheets("Main").Activate 'Make Main the active ws
    Exit Sub
    End If
    
End Sub


Function IndexExists(sSheet As String) As Boolean
On Error Resume Next
    sheetExist = (ActiveWorkbook.Sheets(sSheet).Index > 0)
End Function

Because the CVE strings are not the same, it is not possible to sort them, so there can be a CVE for Microsoft in one row and then a few rows of other CVEs, and the Microsoft again and so on.

I tried to post picture examples of the Index worksheet, the worksheet names, and an example of the data in the lines, but I don't have enough reputation.

So, a few examples (out of over 7,000 lines) of the string data is that is searched for the keyword (column E):

*[MS20-DEC] Microsoft Windows Cloud Files Mini Filter Driver Elevation of Privilege Vulnerability - CVE-2020-17134 [APSB16-04]


*Adobe Flash Player <20.0.0.306 Remote Code Execution Vulnerability - CVE-2016-0964 [MS21-JUN] * 

*Microsoft Kerberos AppContainer Security Feature Bypass Vulnerability - CVE-2021-31962


*McAfee Agent <5.6.6 Local Privilege Escalation Vulnerability - CVE-2020-7311


*7-Zip <18.00 and p7zip Multiple Memory Corruption Vulnerabilities - CVE-2018-5996

1 Answer 1

0

Scan the sheets for a word and then scan down the strings in sheet Main for that word. Scan up the sheet to delete rows.

update - muliple words per sheet

Option Explicit
Sub SearchWords()

    Const COL_TEXT = "E"
    Const ROW_TEXT = 5 ' first line of text

    Dim wb As Workbook
    Dim ws As Worksheet, wsMain As Worksheet, wsIndex As Worksheet
    Dim arData(), arDelete() As Boolean
    Dim lastrow As Long, i As Long, n As Long, r As Long
    Dim word As String, txt As String
    Dim t0 As Single: t0 = Timer
    Dim w
    
    ' create index if not exists
    CreateIndex
    
    Set wb = ActiveWorkbook
    With wb
        Set wsMain = .Sheets("Main")
        Set wsIndex = .Sheets("Index")
    End With
    
    ' copy strings into array for speed
    With wsMain
         lastrow = .Cells(.Rows.Count, COL_TEXT).End(xlUp).Row
         If lastrow < ROW_TEXT Then
             MsgBox "No text found in column " & COL_TEXT, vbCritical
             Exit Sub
         End If
         arData = .Cells(1, COL_TEXT).Resize(lastrow).Value2
         ReDim arDelete(1 To lastrow)
    End With
    
    ' scan main for each keyword in index
    i = 2 ' index row
    Application.ScreenUpdating = False
    For Each ws In wb.Sheets
        If ws.Name <> "Index" And ws.Name <> "Main" Then
            'word = ws.Name
            lastrow = ws.Cells(ws.Rows.Count, "E").End(xlUp).Row
            For Each w In Split(ws.Name, "+")
                word = Trim(w)
                For r = ROW_TEXT To UBound(arData)
                    txt = arData(r, 1)
                    If InStr(1, txt, word, vbTextCompare) > 0 Then
                        lastrow = lastrow + 1
                        wsMain.Rows(r).Copy ws.Cells(lastrow, 1)
                        arDelete(r) = True
                        n = n + 1
                    End If
                Next
            Next
        
            ' update index
            wsIndex.Cells(i, 1) = ws.Name
            wsIndex.Cells(i, 2) = lastrow - 1
            i = i + 1
        End If
    Next
    
    ' delete or highlight rows
    ' scan upwards
    For r = UBound(arDelete) To ROW_TEXT Step -1
       If arDelete(r) = True Then
           wsMain.Cells(r, COL_TEXT).Interior.Color = vbYellow
           'wsMain.Rows(r).Delete 'uncomment to delete
       End If
    Next
    Application.ScreenUpdating = True
    
    MsgBox n & " lines copied", vbInformation, Format(Timer - t0, "0.0 secs")

End Sub

Sub CreateIndex()

    Dim ws As Worksheet, bHasIndex As Boolean
    For Each ws In Sheets
        If ws.Name = "Index" Then bHasIndex = True
    Next
    
    ' create index
    If Not bHasIndex Then
        Worksheets.Add(before:=Sheets(1)).Name = "Index"
    End If
    
    ' format index
    With Sheets("Index")
        .Cells.Clear
        With .Range("A1:B1")
            .Value2 = Array("WS Names", "Count")
            .Font.Size = 14
            .Font.Bold = True
            .Font.Color = vbBlue
        End With
        .Columns("A:B").AutoFit
        .Columns("B:B").HorizontalAlignment = xlCenter
    End With

End Sub
11
  • Hi @CDP1802, I ran your code and am getting an error 9, subscript out of range on the line "Set wsMain = .Sheets("Main")". Do you have any idea why this is ? Also, I noticed you changed the index code (I like the change) but left out the writing of the worksheet names into the Index. any reason ? Nov 24, 2021 at 10:25
  • I do have a Main ws. I tried changing the order of the commands, and placed the "Set wsIndex = .Sheets("Index")" before the Main one, and the script stops on that command now with the same error. and obviously, there is an Index sheet because we created it (you in your script and me in mine). Re the Index, yes, I went through what you sent me and I saw the bit I missed where you update the index per keyword. My bad on that :) Any thoughts on why the error though ? Nov 25, 2021 at 6:14
  • @mike Where have you put the code , Is it in personal macros ? If so change Set wb = ThisWorkbook to Set wb = ActiveWorkbook
    – CDP1802
    Nov 25, 2021 at 6:55
  • ok, @CDP1802, I made the change and now it looks as though it's working. The only issue I have found, is that the count written to the Index is 3 more than the actual amount that was copied, so 10 is 7, 259 is 256 and so on. An easy fix. What I am now going to do is run it with the move command, and see what the results are. So far, it is excellent, clear, and works a dream. As well as being fast. Nov 25, 2021 at 7:09
  • It works like a dream, and I even found that there are certain items I did not create a ws for, so will fix that. Excellent code @CDP1802 !!! One additional question if I may (Feel free to disregard and I'll try to work it out myself). If I want to put different keywords into the same ws, how would I go about that ? I have marked your answer as the perfect reply. Nov 25, 2021 at 8:08

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.