向多个 Excel 电子表格添加一列，列条目是 Excel 文件名的名称。然后将工作表合并到一个电子表格中

Question

我需要将多个电子表格合并到一个工作簿中，还要合并到一个合并的电子表格中。每个文件有 1000 多行，三个目录大约有 40-50 个这样的文件。这些可以单独组合，因为它们代表三年的人事记录。

我有一个 VBA 宏，可以成功地将工作表放入一个工作簿中。我还有一个宏，用于将这些工作表组合到一个附加的电子表格中。但是，我需要在组合文件的第一行之后取出每个连续文件数据添加的标题行。

此外，我需要使用宏在每个文件中创建一列，每行填充文件名（这样，一旦与其他文件合并，就可以清楚每个数据点来自哪个源）或找到一个在组合工作表时执行此操作的宏。如果是前者使用对每个文件执行此操作的宏，在我使用单个电子表格组合宏之前，那么我需要的只是更新我的最终宏，它只为第一行放置一个标题行。以下是数据示例：

我需要最终文件在 A 中的列（新创建的列）中包含该行所来自的每个文件源的文件名。请参阅下面的示例，了解我希望组合结果的样子：

这是我用于将多个选项卡/电子表格组合到一个电子表格中的宏：

Sub Merge_Sheets()
    'Insert a new worksheet
    Sheets.Add

    'Rename the new worksheet
    ActiveSheet.Name = "YearlyCompilation"

    'Loop through worksheets and copy the to your new worksheet
    For Each ws In Worksheets
        ws.Activate

        'Don't copy the merged sheet again
        If ws.Name <> "YearlyCompilation" Then
            ws.UsedRange.Select
            Selection.Copy
            Sheets("YearlyCompilation").Activate

            'Select the last filled cell
            ActiveSheet.Range("A1048576").Select
            Selection.End(xlUp).Select

            'For the first worksheet you don't need to go down one cell
            If ActiveCell.Address <> "$A$1" Then
                ActiveCell.Offset(1, 0).Select
            End If

            'Instead of just paste, you can also paste as link, as values etc.
            ActiveSheet.Paste

        End If

    Next
End Sub

Answer 1

这可能是冗长的，并且可能错过了标记，但是下面的宏会将共享维度和标题行的多个工作表的值组合到一个新工作表中，其中包含文件名的附加列和只有一个标题行.

它不会保留源格式或公式，并且出于速度原因，它使用数组在 VBA 空间中构建新工作表。如果输入工作表的列数不同，我还包括错误检查。

Option Explicit

Public Sub Merge_Sheets()
    On Error GoTo ErrorHandler

    Dim ws As Worksheet
    Dim varInput() As Variant
    Dim varOutput() As Variant
    Dim colData As Collection
    Dim colWsName As Collection
    Dim lRows As Long
    Dim lColumns As Long
    Dim lOutputRow As Long
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim l As Long

    OptimizationON

    Set colData = New Collection
    Set colWsName = New Collection

    'Loads source data into Array, then loads array into a collection
    For Each ws In ActiveWorkbook.Worksheets
        varInput() = ws.UsedRange.Value2
        colData.Add varInput()
        colWsName.Add ws.name

    Next ws

    lRows = 0
    lColumns = 0

    'Determines how many rows and columns the final output array will need
    For i = 1 To colData.Count
        lRows = lRows + UBound(colData(i))

        If i = 1 Then
            lColumns = UBound(colData(i), 2)

        Else
            If lColumns <> UBound(colData(i), 2) Then
                MsgBox "Input worksheets have a different number of columns!", vbCritical, "ERROR!"
                OptimizationOFF
                Exit Sub

            End If

        End If

    Next i

    lColumns = lColumns + 1
    lRows = lRows - i + 2

    'Initializes the output array
    ReDim varOutput(1 To lRows, 1 To lColumns)

    'Loads the data into the output array
    lOutputRow = 1
    l = 0

    For i = 1 To colData.Count
        If i > 1 Then l = 1

        For j = 1 To UBound(colData(i)) - l
            For k = 1 To UBound(colData(i), 2) + 1
                If k = 1 Then
                    If lOutputRow = 1 Then
                        varOutput(lOutputRow, k) = "Filename"

                    Else
                        varOutput(lOutputRow, k) = colWsName(i)

                    End If

                Else
                    varOutput(lOutputRow, k) = colData(i)(j + l, k - 1)

                End If
            Next k

            lOutputRow = lOutputRow + 1

        Next j

    Next i

    'Creates a new worksheet and loads the data into it
    Set ws = ActiveWorkbook.Sheets.Add

    ws.name = "YearlyCompilation"

    ArrayToWorksheet varOutput(), ws

ErrorHandler:
    OptimizationOFF

End Sub

Private Sub ArrayToWorksheet(ByVal varArray As Variant, ByRef ws As Worksheet)
    'Loads an array into a worksheet
    Dim range As range

    Set range = ws.range("A1")

    Debug.Assert range.Address = "$A$1"

    Set range = range.Resize(UBound(varArray, 1), UBound(varArray, 2))

    range.Value2 = varArray

End Sub

Private Sub OptimizationON()
    'Disables certain features to speed up calculation
    With Application
        .ScreenUpdating = False
        .DisplayStatusBar = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        .PrintCommunication = False

    End With

End Sub

Private Sub OptimizationOFF()
    'Re-enables disabled features
    With Application
        .ScreenUpdating = True
        .DisplayStatusBar = True
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .PrintCommunication = True
    End With

End Sub