将行从多个工作簿复制到具有匹配列值的摘要工作簿的宏

Question

我有不同的工作簿，不同的工作表具有相同的工作表名称。（Book1，Book2，Book3，excel1，excel2，micorsoft 等）在一个文件夹中。

我想创建一种方法，将整行（输入数据时）传输到具有单元格中匹配值的摘要工作簿。请参阅下面的示例表。

如果您注意到下面的示例，我有一个 Book1 和 worksheet1（它也有不同的工作表和这个一起）。

现在我的要求是从文件夹中的所有工作簿中将具有匹配状态列单元格（例如：NEW、research）的整行复制到运行宏的工作簿中。

我请求是否有人可以帮助我处理这个很棒的宏。

注意：

并非总是如此，但有时这些数据会不时更改，因此必须使用最新的数据进行覆盖。我只是希望将所有内容合并到 1 个工作簿中，以便我可以从那里获取数据。 这是可以轻松完成的事情吗？我已经在一些宏上尝试了运气，但我似乎无法得到它。

书1

工作表 1

column A    column B    column C        status  comment column D
                                        Update      
                                        New     
                                        Modified        
                                        New     
                                        New     
                                        Research        
                                        Research

我很幸运地得到了一个代码，可以在一本书中从一张纸复制到另一张纸，代码如下

代码：

Sub Foo()
Dim i As Long, iMatches As Long
Dim aTokens() As String: aTokens = Split("New,research", ",")
For Each cell In Sheets("Worrksheet1").Range("E:E")
    If (Len(cell.Value) = 0) Then Exit For
        For i = 0 To UBound(aTokens)
            If InStr(1, cell.Value, aTokens(i), vbTextCompare) Then
                iMatches = (iMatches + 1)
                Sheets("Worrksheet1").Rows(cell.Row).Copy Sheets("final").Rows(iMatches)
            End If
        Next
Next
End Sub

说明：

此代码将复制所有行内容，其中匹配 NEW、research 或列 E 中所需的任何内容：E 从 Worksheet1 工作表到最终工作表

现在需要更改的是从文件夹中的不同工作簿（给定的目录路径）复制到相同或不同文件夹中的单个工作簿中。

如果我可以选择通过电子邮件发送副本，如下面的链接 会很棒 Creating a Windows application which reads and writes excel spreadsheets + reads and writes emails

Answer 1

我不完全确定我理解你的目标......但是。 打开要复制的所有工作簿。 将以下代码粘贴到其中一个工作簿中的标准模块中（不管是哪个工作簿）运行它。 该代码创建一个新工作簿并查看每个工作表中每个工作簿的第 1 行中的每个单元格。 （除了刚刚创建的那个） 如果它不是空白的，它将整个列复制到相同工作表编号和相同列位置的新工作簿中。干杯。

Sub alltoone()
Application.ScreenUpdating = False
j = 0
ght = 0
Set nwrk = Workbooks.Add
For i = 1 To Workbooks.Count - 1
ght = Application.WorksheetFunction.Max(ght, Workbooks(i).Worksheets.Count)
Next i
If ght > nwrk.Worksheets.Count Then
    Do
        nwrk.Worksheets.Add
    Loop Until ght = nwrk.Worksheets.Count
End If
For i = 1 To Workbooks.Count - 1
     For k = 1 To Workbooks(i).Worksheets.Count
         For t = 1 To 256
         Set fez = Workbooks(i).Worksheets(k).Cells(1, t)
         If Not fez.Value = Empty Then
         fez.EntireColumn.Copy
         nwrk.Worksheets(k).Columns(t).EntireColumn.PasteSpecial
         End If
         Next t
     Next k
 Next i
 Set nwrk = Nothing
 Set fez = Nothing
 Application.ScreenUpdating = True
 End Sub