Question

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

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

如果你注意到下面的例子，我有一个带有工作表1的Book1（它也有不同的工作表和这个工作表）。

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

我请求是否有人可以帮助我使用这个非常棒的宏。

注意：

并非总是如此，但有时这些数据会不时发生变化，因此必须使用最新数据保持覆盖。我只想把它整合到1个工作簿上，这样我就可以从那里得到数据。这可以轻松完成吗？我在一些宏上尝试过运气，但我似乎无法得到它。

第一册

Worrksheet1

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，研究或Erk E：E列中任何所需的词语，从Worrksheet1表格到最终表格

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

如果我可以选择通过电子邮件发送下面提到的副本链接会很棒 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

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

1 个答案: