我有一个Excel工作表，名为"主"；其中包括一定数量的列，其中一列包含关于需要根据来自互联网的标准安装在工作表上的补丁的不同代码(CVE(的列表。
要搜索的代码不是设置的格式，而是包含代码的字符串。
我根据这些字符串中的关键字手动创建了许多工作表，这些工作表最终将包含主表中的所有行，但仅包含由我想要的关键字名称定义的行。
例如，我有一个名为"；微软；其应包含来自主表的引用Microsoft CVE的所有行；微软"；。Adobe等也是如此。
我创建了一个脚本来复制行，并创建一个新的索引表，该表列出了为每个关键字找到的已从主表复制到相关表的行数。
这就是我迷路的地方。
我有18张同样是关键词的工作表。我可以定义一个关键字，然后从主工作表中为一个关键字复制所有内容。
我需要一个循环(可能是循环中的循环(，它读取索引中定义的工作表名称，搜索包含与该关键字相关的CVE的所有相关行，然后将一路领先复制到我创建的相关工作表中的相关行
例如，如果我复制了两行，则下一行应写入下一行，依此类推，直到我遍历了所有工作表(关键字(名称并到达"索引"工作表中最后一个名称后的空行。
我的代码，只为一个关键字设置一个有限的运行来测试工作
我需要循环浏览所有关键字并复制所有数据
最后，我想将主工作表(Main(中的相关行复制到相关工作表(基于索引工作表中的关键字工作表名称(，并在从主工作表中复制行后删除该行
我最终应该将所有数据拆分为相关的工作表和一个空的(除了标题(主工作表。
这就是我到目前为止所拥有的(从各种例子和我自己的东西来看(。
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
因为CVE字符串不相同，所以不可能对它们进行排序，所以可以在一行中有一个Microsoft的CVE，然后在几行中有其他CVE，再加上Microsoft，以此类推
我试着发布索引工作表的图片示例、工作表名称和行中数据的示例，但我没有足够的声誉。
因此，字符串数据的几个例子(在7000多行中(就是搜索关键字(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
扫描表单中的单词，然后向下扫描表单Main中的字符串以查找该单词。扫描工作表以删除行。
更新-每页多个单词
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