将所有工作簿与文件夹中的所有工作表合并

Question

我已经下载了a macro，它运行良好，但我想合并所有工作簿工作表。这个宏只得到第一个工作表：

Sub MergeAllWorkbooks()
Dim SummarySheet As Worksheet
Dim FolderPath As String
Dim NRow As Long
Dim FileName As String
Dim WorkBk As Workbook
Dim SourceRange As Range
Dim DestRange As Range

Application.DisplayAlerts = False
Application.ScreenUpdating = False


' Create a new workbook and set a variable to the first sheet.
'Set SummarySheet = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

Set SummarySheet = ThisWorkbook.Sheets.Add
SummarySheet.Name = "ALL"

'Clear all old data
SummarySheet.Cells.Delete

' Modify this folder path to point to the files you want to use.
FolderPath = "C:\excel\"

' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 1

' Call Dir the first time, pointing it to all Excel files in the folder path.
FileName = Dir(FolderPath & "*.xl*")

' Loop until Dir returns an empty string.
Do While FileName <> ""
    ' Open a workbook in the folder
    Set WorkBk = Workbooks.Open(FolderPath & FileName)

    ' Set the cell in column A to be the file name.
    SummarySheet.Range("A" & NRow).Value = FileName

    ' Set the source range to be A9 through C9.
    ' Modify this range for your workbooks.
    ' It can span multiple rows.
    Dim LastRow As Long
     LastRow = WorkBk.Worksheets(1).Cells.Find(What:="*", _
             After:=WorkBk.Worksheets(1).Cells.Range("A1"), _
             SearchDirection:=xlPrevious, _
             LookIn:=xlFormulas, _
             SearchOrder:=xlByRows).Row

    Set SourceRange = WorkBk.Worksheets(1).Range("A1:AA" & LastRow1)

    ' Set the destination range to start at column B and
    ' be the same size as the source range.
    Set DestRange = SummarySheet.Range("B" & NRow)
    Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)

    ' Copy over the values from the source to the destination.
    DestRange.Value = SourceRange.Value

    SourceRange.Copy
    DestRange.PasteSpecial (xlPasteFormats)
    Application.CutCopyMode = False



    ' Increase NRow so that we know where to copy data next.
    NRow = NRow + DestRange.Rows.Count

    ' Close the source workbook without saving changes.
    WorkBk.Close savechanges:=False

    ' Use Dir to get the next file name.
    FileName = Dir()
Loop

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub  

在我的 .xl* 文件中，有可变数量的工作表（有时是一张，有时是六张）。

您能帮我循环打开工作簿中的每张工作表吗？

Answer 1

最简单的方法是将每个工作表保存为单独的工作簿。只要工作簿的数量有限，这将需要非常少的努力。

另一种解决方案是为 .这将在以下时间开始：

' Open a workbook in the folder
Set WorkBk = Workbooks.Open(FolderPath & FileName)

会是这样的：

Dim L As Long
L = ThisWorkbook.Worksheets.Count
For Worksheets 1 to L

然后在后面插入一个NEXT

' Increase NRow so that we know where to copy data next.
NRow = NRow + DestRange.Rows.Count

我不是这方面的真正专家，但过去几周我一直在做类似的事情，所以请告诉我是否有帮助。

Answer 2

我会说 user148116 非常接近。但是从那里发生了一些变化。

这样设置循环

Dim L As Long
For L = 1 To WorkBk.Worksheets.Count

也将 1 替换为 L，例如

Set SourceRange = WorkBk.Worksheets(L).Range("A1:AA" & LastRow1)

（p.s. LastRow1 不应该是 LastRow 吗？）

最终结果（对于内部循环）如下所示：

' Loop until Dir returns an empty string.
Do While Filename <> ""
    ' Open a workbook in the folder
    Set WorkBk = Workbooks.Open(FolderPath & Filename)

    Dim L As Long
    For L = 1 To WorkBk.Worksheets.Count

        ' Set the cell in column A to be the file name.
        SummarySheet.Range("A" & NRow).Value = Filename

        ' Set the source range to be A9 through C9.
        ' Modify this range for your workbooks.
        ' It can span multiple rows.
        Dim LastRow As Long
         LastRow = WorkBk.Worksheets(L).Cells.Find(What:="*", _
                 After:=WorkBk.Worksheets(L).Cells.Range("A1"), _
                 SearchDirection:=xlPrevious, _
                 LookIn:=xlFormulas, _
                 SearchOrder:=xlByRows).Row

        Set SourceRange = WorkBk.Worksheets(L).Range("A1:AA" & LastRow1)

        ' Set the destination range to start at column B and
        ' be the same size as the source range.
        Set DestRange = SummarySheet.Range("B" & NRow)
        Set DestRange = DestRange.Resize(SourceRange.Rows.Count, SourceRange.Columns.Count)

        ' Copy over the values from the source to the destination.
        DestRange.Value = SourceRange.Value

        SourceRange.Copy
        DestRange.PasteSpecial (xlPasteFormats)
        Application.CutCopyMode = False

        ' Increase NRow so that we know where to copy data next.
        NRow = NRow + DestRange.Rows.Count

    Next L

    ' Close the source workbook without saving changes.
    WorkBk.Close savechanges:=False

    ' Use Dir to get the next file name.
    Filename = Dir()
Loop