搜索多个短语;复制到多张纸上的单张纸

Question

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

1. 搜索表1 - X为连续
2. 复制一个“打开”或“过期”的价值的所有行与价值观从第3行开始（所以我可以添加模板的标题）到一张单独的表格（例如分类帐）
3. 添加列A与表名，以便我知道它来自哪个作业。
4. 运行这个我心里强迫性行为的乐趣与新项目，以更新

我曾尝试使用下面的职位，以帮助被指导我：

• Search a specific word and copy line to another Sheet < - 这是有益的，但不相当正确...

• Copying rows to another worksheet based on a search on a grid of tags < - 也很有帮助，但仅限于activesheet，并没有正确循环我的修改ns ...

最后两个晚上很有趣，但我觉得我可能会让这个难度超过需要。

我能够创建一个VBA脚本（从另一篇文章编辑）扫过所有的工作表，但它被设计为复制一组列中的所有数据。我测试了它，它工作。然后，我将C列中的“Open”或“Past Due”代码库（仅适用于activesheet）的代码库合并到代码中。我标记了我的编辑以在此共享。此时它不起作用，我自己也晕了过去。任何有关我在哪里编码的提示将值得赞赏。我的代码基础，我从工作是：

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 

和拷贝匹配从Activesheet数据如下：

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 

Answer 1

你应该看看这个Vba macro to copy row from table if value in table meets condition

在你的情况下，你需要创建一个循环，使用此高级过滤器将数据复制到目标范围或数组。

如果您需要进一步的建议，请发布您的代码，以及您坚持的地方。