如何批量提取多工作表指定列数据横向合并到新工作表

直接用VBA脚本一键完成即可，不需要手动写整列引用公式，也不会因为整列引用导致文件卡顿，步骤如下：

• 打开目标工作簿，按快捷键Alt+F11调出VBA编辑窗口
• 在左侧的工程资源管理器面板中，右键点击当前工作簿名称，依次选择「插入」-「模块」
• 将下方代码粘贴到弹出的空白代码编辑区：

Sub MergeSpecifiedColumns()
    Dim wsSummary As Worksheet, ws As Worksheet
    Dim lastDataRow As Long, writeCol As Long, appendIndex As Long
    Application.ScreenUpdating = False
    
    ' 新建汇总表，放在工作簿最开头
    Set wsSummary = ThisWorkbook.Worksheets.Add(Before:=ThisWorkbook.Worksheets(1))
    wsSummary.Name = "合并结果"
    writeCol = 1
    
    ' 先写入Data表的H、I列数据
    Set ws = ThisWorkbook.Worksheets("Data")
    lastDataRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
    If lastDataRow >= 1 Then
        ws.Range("H1:H" & lastDataRow).Copy wsSummary.Cells(1, writeCol)
        ws.Range("I1:I" & lastDataRow).Copy wsSummary.Cells(1, writeCol + 1)
        writeCol = writeCol + 2
    End If
    
    ' 按序号遍历所有Append开头的工作表
    appendIndex = 1
    Do
        On Error Resume Next
        Set ws = ThisWorkbook.Worksheets("Append" & appendIndex)
        On Error GoTo 0
        If ws Is Nothing Then Exit Do
        
        lastDataRow = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row
        If lastDataRow >= 1 Then
            ws.Range("H1:H" & lastDataRow).Copy wsSummary.Cells(1, writeCol)
            ws.Range("I1:I" & lastDataRow).Copy wsSummary.Cells(1, writeCol + 1)
            writeCol = writeCol + 2
        End If
        appendIndex = appendIndex + 1
        Set ws = Nothing
    Loop
    
    Application.ScreenUpdating = True
    MsgBox "合并完成，共汇总" & (writeCol - 1) / 2 & "个工作表的H、I列数据"
End Sub

• 按F5运行代码，等待弹窗提示完成后，回到Excel界面即可看到名为「合并结果」的新工作表，数据排列顺序完全符合要求：先放Data表的H列、I列，后续按Append1、Append2……的序号依次拼接对应表的H列、I列。

注意事项 #

• 代码只会复制各表H列实际有数据的行，不会整列引用造成文件体积暴涨、运算卡顿
• 脚本自动跳过Calc、Settings工作表，不需要手动做排除操作
• 如果不需要保留各表的表头行，把代码中所有H1、I1修改为H2、I2，同时把wsSummary.Cells(1, writeCol)里的行号1改成2即可
• 运行脚本前建议先备份原文件，避免误操作导致数据丢失

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