VBA多工作表数据合并：请求将纵向粘贴改为横向粘贴

嘿，刚接触VBA不用慌！我帮你把代码改成横向排列粘贴的版本，还会拆解关键改动点，方便你理解和调整～

修改后的完整代码 #

Sub 横向汇总到Archive()
    Dim ws As Worksheet
    Dim wsArchive As Worksheet
    Dim LastCol As Long
    Dim DataRange As Range
    
    ' 检查是否存在Archive工作表，不存在则新建
    On Error Resume Next
    Set wsArchive = ThisWorkbook.Worksheets("Archive")
    On Error GoTo 0
    
    If wsArchive Is Nothing Then
        Set wsArchive = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
        wsArchive.Name = "Archive"
    Else
        ' 如果Archive已存在，清空现有数据（可选，不想清空就删掉这行）
        wsArchive.Cells.Clear
    End If
    
    ' 循环遍历所有工作表，跳过Archive本身
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Archive" Then
            ' 获取当前工作表的有效数据范围（默认从A1开始的已用区域）
            Set DataRange = ws.UsedRange
            
            ' 定位Archive中最后一列的下一列位置
            LastCol = wsArchive.Cells(1, Columns.Count).End(xlToLeft).Column
            ' 第一个工作表直接从第1列开始，后续工作表往后挪一列避免覆盖
            If LastCol > 1 Then LastCol = LastCol + 1
            
            ' 把当前表的数据横向粘贴到Archive对应列
            DataRange.Copy Destination:=wsArchive.Cells(1, LastCol)
        End If
    Next ws
    
    MsgBox "横向汇总搞定啦！", vbInformation
End Sub

关键改动说明（新手必看） #

• 核心逻辑切换：从「找最后一行」到「找最后一列」
  原来纵向汇总是找Archive的最后一行往下贴，现在横向改成找最后一列往右贴。这里用wsArchive.Cells(1, Columns.Count).End(xlToLeft).Column定位当前最靠右的列，再判断是否要+1（第一个表不用加，避免空出第一列）。
• 粘贴目标调整：从「行起始」到「列起始」
  原来粘贴到wsArchive.Cells(LastRow, 1)（某行第一列），现在改成wsArchive.Cells(1, LastCol)（第一行某列），实现横向并排的效果。
• 可选的清空机制
  如果Archive表已经存在，代码会先清空旧数据，避免重复汇总。要是你想保留历史数据，直接删掉wsArchive.Cells.Clear这行就行。

小提示 #

• 如果你的工作表数据不是从A1开始，或者有合并单元格，可以把Set DataRange = ws.UsedRange改成具体范围，比如Set DataRange = ws.Range("A1:Z100")。
• 汇总后可以加一行wsArchive.Columns.AutoFit自动调整列宽，让排版更整齐～

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