VBA合并文件夹内Excel数据到单工作表 列头复制功能实现求助

VBA代码修改方案 #

你原有代码默认跳过了源表第一行表头，且无首次写入表头的判断逻辑，按以下方案修改即可实现需求：

修改后完整代码 #

Sub ConsolidateWorkbooks()
Dim FolderPath As String, Filename As String, sh As Worksheet, ShMaster As Worksheet
Dim wbSource As Workbook, lastER As Long, arr, isFirstLoad As Boolean

' 新建汇总工作表
Set ShMaster = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Sheets.Count))
' 初始化首次写入标记
isFirstLoad = True

Application.ScreenUpdating = False
FolderPath = "P:\FG\03_OtD_Enabling\Enabling\Teams\Enabling_RPA\Other Automations\Excel Merge Several Files\Data\"
Filename = Dir(FolderPath & "*.xls*")
Do While Filename <> ""
    Set wbSource = Workbooks.Open(Filename:=FolderPath & Filename, ReadOnly:=True)
    For Each sh In wbSource.Worksheets
        lastER = ShMaster.Range("A" & Rows.Count).End(xlUp).Row
        If isFirstLoad Then
            ' 首次写入时读取包含表头的全量数据
            arr = sh.UsedRange.Value
            isFirstLoad = False
            ' 首次写入从第一行开始
            ShMaster.Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr
        Else
            ' 非首次写入跳过表头，仅读取数据区域
            arr = sh.Range(sh.UsedRange.Cells(1, 1).Offset(1, 0), _
                    sh.Cells(sh.UsedRange.Rows.Count, sh.UsedRange.Columns.Count)).Value
            ' 从汇总表最后一行的下一行开始写入
            ShMaster.Range("A" & lastER + 1).Resize(UBound(arr), UBound(arr, 2)).Value = arr
        End If
    Next sh
    wbSource.Close
    Filename = Dir()
Loop
Application.ScreenUpdating = True
End Sub

核心修改说明 #

• 新增isFirstLoad布尔变量，仅首次处理源表时同步写入表头，后续文件仅写入数据避免表头重复
• 修正原代码中循环工作表时调用ActiveWorkbook的不稳定写法，直接使用预定义的wbSource变量指向源文件，兼容性更强
• 拆分首次写入和后续写入的行号逻辑，避免汇总表首行出现空行

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