VBA多工作表数据合并异常：仅保留最后一个工作表数据

你的代码逻辑完全搞反了——你要的是把每个工作表的数据向下追加到Master表的行末，但当前代码是把数据横向粘贴到第1行的新列，最后还删除了第一列，自然只剩最后一次粘贴的内容。

错误核心点 #

• Range("A:D").End(xlUp).Column + 1：这是获取A-D区域最后一列的列号，加1得到下一列，然后Cells(1, col)把数据粘贴到Master表的第1行该列，相当于每次都往右侧贴，而非向下追加。
• 最后执行Columns(1).Delete，删除第一列后所有内容左移，前面粘贴的全部被覆盖，只剩最后一次的结果。

修正后的代码 #

Sub MasterSheet3()
    Dim ws As Worksheet
    Dim lastRow As Long ' 用Long适配大行数，避免Integer溢出

    Application.ScreenUpdating = False
    
    ' 先删除已存在的Master表（避免重复创建报错）
    On Error Resume Next
    Sheets("Master").Delete
    On Error GoTo 0
    Sheets.Add(Before:=Sheets(1)).Name = "Master"
    
    ' 遍历所有非Master工作表
    For Each ws In Worksheets
        If ws.Name <> "Master" Then
            ' 获取Master表A列最后有数据的行号
            lastRow = Sheets("Master").Range("A" & Rows.Count).End(xlUp).Row
            ' 处理空表情况：如果A1为空，从第1行开始粘贴
            If lastRow = 1 And Sheets("Master").Range("A1").Value = "" Then
                lastRow = 0
            End If
            ' 复制目标区域并粘贴到Master表的下一行
            ws.Range("A4:D8").Copy
            Sheets("Master").Range("A" & lastRow + 1).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End If
    Next ws
    
    ' 自动调整列宽（可选优化）
    Sheets("Master").Columns("A:D").AutoFit
    Sheets("Master").Range("A1").Activate
    Application.ScreenUpdating = True
End Sub

关键修改说明 #

1. 替换列逻辑为行逻辑：用lastRow追踪Master表的最后数据行，Range("A" & Rows.Count).End(xlUp).Row是查找A列最后一行的标准写法，精准定位追加位置。
2. 增加重复表处理：先删除已存在的Master表，避免重复创建报错。
3. 去除冗余操作：删掉不必要的Activate，直接通过工作表名称引用，代码更高效稳定。
4. 空表判断：处理第一次粘贴时的空表情况，确保从第一行开始粘贴。

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