合并不同工作簿工作表时出现空白行及表头重复问题

合并多个列结构相同的工作簿工作表时，出现大量空白行且表头重复。部分源工作表仅含表头或无数据，使用VBA合并后出现上述问题，需明确原因并修复。

问题原因分析 #

• 重复表头：原代码每次循环都复制源表的表头行，但未判断目标工作表是否已存在表头，导致每个源表的表头都被追加到目标表中。
• 空白行：
  1. 原代码中With Sheets("Sheet1")引用的是当前工作簿的Sheet1，而非打开的源工作簿工作表，导致lastRow判断完全错误，可能复制大量空行。
  2. 当源表只有表头（lastRow=1）时，执行Rows("2:" & lastRow).Copy会尝试复制不存在的行，结合Offset(1)会在目标表新增空白行。
  3. 源表无数据时，同样会触发无效的复制操作，产生空白行。
• 额外逻辑错误：原代码末尾错误地将A列从第一行到End(xlDown)的行全部加粗，不符合需求。

修复后的VBA代码 #

Private Sub cmdCombine_Click()
    Dim SourceFolder As String
    Dim CurrentWorkbook As Workbook
    Dim DestinationWorksheet As Worksheet
    Dim SourceFile As String
    Dim SourceWorkbook As Workbook
    Dim SourceWorksheet As Worksheet
    Dim lastRow As Long
    Dim destLastRow As Long
    
    ' 设置源文件夹路径
    SourceFolder = "C:\Users\v1kvazir\OneDrive - University of Edinburgh\Data\Raw\"
    
    ' 设置当前工作簿
    Set CurrentWorkbook = ThisWorkbook
    
    ' 创建或获取名为"Data"的目标工作表
    On Error Resume Next
    Set DestinationWorksheet = CurrentWorkbook.Sheets("Data")
    On Error GoTo 0
    
    If DestinationWorksheet Is Nothing Then
        Set DestinationWorksheet = CurrentWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
        DestinationWorksheet.Name = "Data"
    End If
    
    ' 仅在目标表为空时复制表头
    If WorksheetFunction.CountA(DestinationWorksheet.Cells) = 0 Then
        ' 先打开第一个文件获取表头（如果有文件的话）
        SourceFile = Dir(SourceFolder & "*.xlsx")
        If SourceFile <> "" Then
            Set SourceWorkbook = Workbooks.Open(SourceFolder & SourceFile)
            Set SourceWorksheet = SourceWorkbook.Sheets(1)
            SourceWorksheet.Rows(1).Copy Destination:=DestinationWorksheet.Range("A1")
            SourceWorkbook.Close False
            ' 继续遍历下一个文件
            SourceFile = Dir
        End If
    Else
        ' 目标表已有内容，直接开始遍历文件
        SourceFile = Dir(SourceFolder & "*.xlsx")
    End If
    
    ' 遍历文件夹中的所有xlsx文件
    Do While SourceFile <> ""
        Application.ScreenUpdating = False
        
        Set SourceWorkbook = Workbooks.Open(SourceFolder & SourceFile)
        Set SourceWorksheet = SourceWorkbook.Sheets(1)
        
        ' 正确获取源工作表的最后一行（修复原代码引用错误）
        With SourceWorksheet
            If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                lastRow = .Cells.Find(What:="*", _
                              After:=.Range("A1"), _
                              Lookat:=xlPart, _
                              LookIn:=xlFormulas, _
                              SearchOrder:=xlByRows, _
                              SearchDirection:=xlPrevious, _
                              MatchCase:=False).Row
            Else
                lastRow = 1
            End If
        End With
        
        ' 仅当源表有数据行（lastRow>1）时才复制数据
        If lastRow > 1 Then
            destLastRow = DestinationWorksheet.Cells(DestinationWorksheet.Rows.Count, "A").End(xlUp).Row
            SourceWorksheet.Rows("2:" & lastRow).Copy Destination:=DestinationWorksheet.Cells(destLastRow + 1, "A")
        End If
        
        SourceWorkbook.Close False
        SourceFile = Dir
    Loop
    
    Application.ScreenUpdating = True
    
    ' 格式化目标工作表
    With DestinationWorksheet
        .Cells.ClearFormats
        .UsedRange.EntireColumn.AutoFit
        
        ' 确保表头格式正确
        If WorksheetFunction.CountA(.Rows(1)) > 0 Then
            Dim lcolumn As Long
            lcolumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
            With .Range(.Cells(1, 1), .Cells(1, lcolumn))
                .Font.Bold = True
                .Interior.ColorIndex = 40
                .HorizontalAlignment = xlCenter
            End With
        End If
    End With
    
    MsgBox "数据已成功合并至当前工作簿的'Data'工作表！", vbOKOnly + vbInformation, "操作完成"
End Sub

关键修改说明 #

• 避免重复表头：新增判断，仅当目标工作表为空时，从第一个源表复制一次表头，后续源表不再复制表头。
• 修复空白行问题：
  1. 将lastRow的判断对象改为当前打开的源工作表，而非当前工作簿的Sheet1，确保行号判断准确。
  2. 增加If lastRow > 1的判断，只有源表存在数据行时才执行复制操作，避免无效复制产生空白行。
• 优化格式化逻辑：简化格式化代码，修正原代码中错误的A列加粗逻辑，仅对表头进行格式设置。
• 优化遍历流程：调整文件遍历的逻辑，确保表头复制后能正确继续遍历剩余文件。

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