Vba 搜索多个短语；跨多张图纸复制到单个图纸

我正在使用Microsoft Excel跟踪任务。我为每项工作使用不同的“工作表”。结构与列和数据有关。我一直在尝试创建一个VBA脚本，该脚本将实现以下功能：

在第1-X页搜索一行中的“未结”或“过期”值

从第3行开始，将具有这些值的所有行复制到一张工作表（如分类账）中（以便我可以添加模板的标题）

添加一个带有工作表名称的列a，以便我知道它来自哪个作业

运行这个到我的心强迫行为快乐更新与新项目

我一直在使用以下帖子来帮助指导我：

---

• 你应该调查一下
  在您的情况下，需要创建一个循环，使用此高级过滤器将数据复制到目标范围或阵列

  ---

  如果您需要进一步的建议，请发布您的代码，以及您被困在哪里。
  “…并且我的修改没有正确循环…”您可以发布您的代码以便我们看到哪些不起作用吗？嗨，我只是想知道您是否需要保留每行的格式？或者仅仅是数据就足够了？因此，基本上，您要求将所有与工作表名称匹配的行复制到结果工作表中的新行中。。我已经能够使用“标签网格”代码从一张纸上找到一组匹配的行，然后复制到另一张纸上。事实证明，搜索所有工作表并添加结果是很困难的，因为一些ThisWorkbook.sheets（“Sheet1”）（例如）无法找到正确的工作表。我将在今天下午发布代码。。和往常一样，我很感激。我尝试了合并两个独立的代码库，因为这将有15个以上的工作表，并且作为VBA和宏运行起来更高效。感谢你的链接。您可以在共享（也许现在已经损坏）代码中提供的任何清晰性都将非常好。

  Sub SweepSheetsCopyAll()
  
      Application.ScreenUpdating = False
     'following variables for worksheet loop
      Dim W As Worksheet, r As Single, i As Single
     'added code below for finding the fixed values on the sheet
      Dim lastLine As Long
      Dim findWhat As String
      Dim findWhat1 As String
      Dim findWhat2 As String
      Dim toCopy As Boolean
      Dim cell As Range
      Dim h As Long 'h replaced i variable from other code
      Dim j As Long
  
      'replace original findWhat value with new fixed value
  
      findWhat = "Open"
      'findWhat2 = "Past Due"
  
  
      i = 4
      For Each W In ThisWorkbook.Worksheets
          If W.Name <> "Summary" Then
             lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop all rows in a sheet to find last line
              For r = 4 To lastLine 'formerly was "To W.Cells(Rows.Count, 1).End(xlUp).Row"
                  'insert below row match search copy function
                  For Each cell In Range("B1:L1").Offset(r - 1, 0)
                     If InStr(cell.Text, findWhat) <> 0 Then
                        toCopy = True
                     End If
                 Next
              If toCopy = True Then
      ' original code               Rows(r).Copy Destination:=Sheets(2).Rows(j)
       Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
                          ThisWorkbook.Worksheets("Summary").Cells(i, 1)
                  j = j + 1
              End If
              toCopy = False
          'Next
  
                  'end above row match search function
                  'below original code that copied everything from whole worksheet
           '       If W.Cells(r, 1) > 0 Then
     '                 Range(W.Cells(r, 1), W.Cells(r, 12)).Copy _
      '                    ThisWorkbook.Worksheets("Summary").Cells(i, 1)
            '          i = i + 1
             '     End If
              Next r
          End If
      Next W
  End Sub
  

  Sub GetParts()
      Application.ScreenUpdating = False
      Dim W As Worksheet, r As Single, i As Single
      i = 4
      For Each W In ThisWorkbook.Worksheets
          If W.Name <> "Summary" Then
              For r = 4 To W.Cells(Rows.Count, 1).End(xlUp).Row
                  If W.Cells(r, 1) > 0 Then
                      Range(W.Cells(r, 1), W.Cells(r, 3)).Copy _
                          ThisWorkbook.Worksheets("Summary").Cells(i, 1)
                      i = i + 1
                  End If
              Next r
          End If
      Next W
  End Sub
  

  Sub customcopy()
  
  Application.ScreenUpdating = False
  Dim lastLine As Long
  Dim findWhat As String
  Dim findWhat1 As String
  Dim findWhat2 As String
  Dim toCopy As Boolean
  Dim cell As Range
  Dim i As Long
  Dim j As Long
  
  'replace original findWhat value with new fixed value
  
  findWhat = "Open"
  'findWhat2 = "Past Due"
  
  lastLine = ActiveSheet.UsedRange.Rows.Count 'Need to figure out way to loop through all sheets here
  
  'below code does nice job finding all findWhat and copying over to spreadsheet2
  j = 1
  For i = 1 To lastLine
      For Each cell In Range("B1:L1").Offset(i - 1, 0)
          If InStr(cell.Text, findWhat) <> 0 Then
              toCopy = True
          End If
      Next
      If toCopy = True Then
          Rows(i).Copy Destination:=Sheets(2).Rows(j)
          j = j + 1
      End If
      toCopy = False
  Next
  
  i = MsgBox(((j - 1) & " row(s) were copied!"), vbOKOnly, "Result")
  
  Application.ScreenUpdating = True
  End Sub