Excel VBA实现多工作表数据合并（去除重复表头）

需求说明：
将指定的多个工作表数据合并到目标工作表TO COPY中，要求仅保留一份表头（所有源表表头一致），每个源表固定11列，数据行数可变。因Excel版本（2016）及数据生成限制，无法使用Power Query或表格功能。

以下是修改完成的VBA代码：

Sub joinAllOutputs()
    Dim sheetName As Variant
    Dim counter As Long
    Dim outputSheetsNamesArr() As Variant
    Dim totalDataRows As Long
    Dim finalArr() As Variant
    Dim finalSheet As Worksheet
    Dim srcSheet As Worksheet
    Dim lastRow As Long
    Dim arrIndex As Long
    Dim row As Long, col As Long

    ' 目标工作表
    Set finalSheet = ThisWorkbook.Sheets("TO COPY")
    ' 清空目标表原有数据（若需保留历史数据可注释此行）
    finalSheet.Cells.Clear

    ' 需要合并的源工作表名称数组
    outputSheetsNamesArr = Array("Output - Sales (Net)", "Output - Hours", "Output - Footfall", _
                                "Output - Transactions", "Output - Conversion", "Output - ATV", _
                                "Output - HS Orders", "Output - HS Sales")

    ' 计算所有源表的总数据行数（不含表头）
    totalDataRows = 0
    For Each sheetName In outputSheetsNamesArr
        Set srcSheet = ThisWorkbook.Sheets(sheetName)
        ' 用A列最后一行确定数据范围，避免K列空值导致的错误
        lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 2 Then ' 确保当前表有数据行
            totalDataRows = totalDataRows + (lastRow - 1)
        End If
    Next sheetName

    ' 初始化最终数组：表头+所有数据行，共11列
    ReDim finalArr(1 To totalDataRows + 1, 1 To 11)

    ' 写入表头（从第一个源表提取）
    Set srcSheet = ThisWorkbook.Sheets(outputSheetsNamesArr(0))
    For col = 1 To 11
        finalArr(1, col) = srcSheet.Cells(1, col).Value
    Next col

    ' 写入所有源表的数据行
    arrIndex = 2 ' 数组从第二行开始存储数据
    For Each sheetName In outputSheetsNamesArr
        Set srcSheet = ThisWorkbook.Sheets(sheetName)
        lastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
        If lastRow >= 2 Then
            For row = 2 To lastRow
                For col = 1 To 11
                    finalArr(arrIndex, col) = srcSheet.Cells(row, col).Value
                Next col
                arrIndex = arrIndex + 1
            Next row
        End If
    Next sheetName

    ' 将最终数组批量写入目标工作表
    finalSheet.Range("A1").Resize(UBound(finalArr, 1), 11).Value = finalArr

    ' 可选：自动调整目标表列宽
    finalSheet.Columns("A:K").AutoFit
End Sub

关键修改说明 #

• 数据范围修正：改用Cells(Rows.Count, "A").End(xlUp).Row获取最后一行，避免因K列空值导致的End(xlDown)错误跳转
• 表头唯一化：仅从第一个源表提取表头，确保目标表只保留一份表头
• 数组高效写入：先将所有数据存入数组，再一次性写入工作表，比逐行写入效率更高
• 空表兼容：判断源表是否有数据行，避免空表导致的运行错误
• 灵活清空设置：默认清空目标表原有数据，若需保留可注释对应代码行

内容的提问来源于stack exchange，提问作者ch4rl1e97