0

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

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

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

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

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

笔记：

并非总是如此，但有时这些数据会不时更改，因此必须使用最新的数据进行覆盖。我只是希望将所有内容合并到 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 工作表到最终工作表

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

如果我可以选择通过电子邮件发送下面提到的副本链接将很棒 创建一个读取和写入 Excel 电子表格 + 读取和写入电子邮件的 Windows 应用程序

4

1 回答 1

0

我不完全确定我明白你在追求什么……但是。打开要复制的所有工作簿。将以下代码粘贴到其中一个工作簿中的标准模块中（不管哪个工作簿）运行它。该代码创建一个新工作簿并查看每个工作表中每个工作簿的第 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
于 2013-07-30T18:26:20.277 回答