I'm not new to vba, but there are certain issues that I constantly struggle with. I tend to find results using google, or looking in here for solutions that others have coded, and then trying to use that code, or a variation of that code to do what I need.
In the current issue I am facing, I have not managed to find a solution that I can understand, that would allow me to do what I need.
To explain the situation, I have an excel ws 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 ws's based on criteria listed from the internet.
The codes I need to search are not in a set format, other than being strings containing the code.
I have 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 have created a script that can copy the rows over, as well as create a new Index sheet that lists the amount of rows found for each keyword that have been copied over 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.
What I need, is 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.
So, if I have for example 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 current code is as follows (Set for only one keyword for a limited run to test, which works great). I really need help with the section that loops through all the keywords and copies all the data over.
In the end, I want to copy the relevant row from the master ws (Main) to the relevant ws (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
'''
I hope what I need is clear, and that someone can point me in the direction of performing the loop I need.
I should add that 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 CVE's, and the Microsoft again and so on.
I tried to post some 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
I'd appreciate any help with the loop section (the rest works fine so far).
Mike
CodePudding user response：
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.
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
' create index if not exists
CreateIndex
Set wb = ThisWorkbook
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 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
' 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