为简单起见，下面的代码只组合了活动工作簿中每个工作表的数据。但是，可以修改该代码以包含其他工作簿。
该代码循环遍历活动工作簿中的每个工作表。对于每个工作表，它循环遍历除标题行之外的每一行。对于每一行，首先将数据传输到一个数组，然后添加到一个集合。然后将集合中的组合数据传输到另一个数组。最后，将数组的内容传输到新创建的工作表。
同样，为了简单起见，我假设每个工作表的数据只包含两列，所以我将currentRow()声明为1-Row by 4-Column数组，前两列存储工作表数据，第三和第四列存储相应的工作簿名称和工作表名称，您需要相应地更改第二维。

Option Explicit

Sub CombineAllData()

    Dim sourceWorkbook As Workbook
    Dim currentWorksheet As Worksheet
    Dim newWorksheet As Worksheet
    Dim currentData() As Variant
    Dim currentRow(1 To 1, 1 To 4) As Variant
    Dim allData() As Variant
    Dim col As Collection
    Dim itm As Variant
    Dim i As Long
    Dim j As Long
    
    Set col = New Collection
    
    Set sourceWorkbook = ActiveWorkbook
    
    For Each currentWorksheet In sourceWorkbook.Worksheets
    
        'get the data from the current worksheet
        currentData = currentWorksheet.Range("a1").CurrentRegion.Value
        
        'add each row of data to the collection, excluding the header row
        For i = LBound(currentData) + 1 To UBound(currentData)
            For j = 1 To 2
                currentRow(1, j) = currentData(i, j)
            Next j
            currentRow(1, 3) = sourceWorkbook.Name
            currentRow(1, 4) = currentWorksheet.Name
            col.Add currentRow
        Next i
        
    Next currentWorksheet
    
    'resize the array to store the combined data
    ReDim allData(1 To col.Count, 1 To 4)
    
    'transfer the data from the collection to the array
    With col
        For i = 1 To .Count
            For j = 1 To 4
                allData(i, j) = .Item(i)(1, j)
            Next j
        Next i
    End With
    
    'add a new worksheet to the workbook
    Set newWorksheet = Worksheets.Add
    
    'transfer the contents of the array to the new worksheet
    newWorksheet.Range("a1").Resize(UBound(allData), UBound(allData, 2)).Value = allData
    
End Sub

堆栈范围

• 为简单起见，假设数据从单元格A1开始，数据为表格格式（一行标题，没有空行或空列），并且数据范围至少有两个单元格。
• 此外，还假定该文件夹只包含源文件。

Sub StackRanges()

    Const sFolderPath As String = "C:\Test\"
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim scoll As Collection: Set scoll = New Collection
    
    Application.ScreenUpdating = False
    
    Dim fsoFile As Object, swb As Workbook, sws As Worksheet
    Dim srCount As Long, scCount As Long, drCount As Long, dcCount As Long
    
    For Each fsoFile In fso.GetFolder(sFolderPath).Files
        Set swb = Workbooks.Open(fsoFile.Path, True, True)
        For Each sws In swb.Worksheets
            With sws.Range("A1").CurrentRegion
                srCount = .Rows.Count - 1 ' lose the header
                If srCount > 0 Then
                    scoll.Add .Resize(srCount).Offset(1).Value
                    drCount = drCount + srCount ' total
                    scCount = .Columns.Count
                    If scCount > dcCount Then dcCount = scCount ' max
                End If
            End With
        Next sws
        swb.Close SaveChanges:=False
    Next fsoFile
    
    If scoll.Count = 0 Then Exit Sub

    Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
     
    Dim sItem, sr As Long, dr As Long, c As Long
    
    For Each sItem In scoll
        For sr = 1 To UBound(sItem, 1)
            dr = dr + 1
            For c = 1 To UBound(sItem, 2)
                dData(dr, c) = sItem(sr, c)
            Next c
        Next sr
    Next sItem

    ' Write the values from the array to a new single-worksheet workbook.
'    With Workbooks.Add(xlWBATWorksheet)
'        .Worksheets(1).Range("A2").Resize(drCount, dcCount).Value = dData
'        .Saved = True ' to close without confirmation
'    End With

    Application.ScreenUpdating = True
    
    MsgBox "Ranges stacked.", vbInformation

End Sub