Question

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

在一行中搜索工作表1 - X的值为“打开”或“过期”
将具有这些值的所有行复制到从第3行开始的单个工作表（例如分类帐）中（因此我可以添加模板的标题）
添加一个带有工作表名称的列A，以便我知道它来自哪个工作。
运行这个让我强烈的强迫行为愉快地用新项目更新

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

Search a specific word and copy line to another Sheet＆lt; - 这很有帮助但不太正确......
Copying rows to another worksheet based on a search on a grid of tags＆lt; - 也很有帮助，但仅限于活动表，而且我的修改没有正确循环...

过去的两个晚上很有趣，但我觉得我可能会比必要的更难。

我能够创建一个VBA脚本（在这里从另一篇文章编辑）来扫描所有工作表，但它被设计为复制一组列中的所有数据。我测试了它并且它起作用了。然后我合并了我用来识别C列中的“打开”或“过期”（仅适用于活动表）的代码库到代码中。我在这里标记了我的编辑内容。在这一点上，它没有运作，我已经自己晕了。关于我在哪里提供代码的任何提示都将不胜感激。我的代码库是：

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

Answer 1

您应该查看此Vba macro to copy row from table if value in table meets condition

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

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

搜索多个短语;在多张纸上复印到单张纸上

1 个答案: