求助：编写Excel Macro从指定工作表复制指定表头列至新工作簿

以下宏可实现从指定工作表中，根据你定义的表头名称提取对应列（包含表头），并复制到新建工作簿中，适配100+列中提取60-70列非连续列的场景：

Sub ExtractColumnsByHeader()
    Dim sourceWs As Worksheet
    Dim newWb As Workbook
    Dim newWs As Worksheet
    Dim headerRow As Integer
    Dim targetHeaders As Variant
    Dim header As Variant
    Dim colIndex As Variant
    Dim destCol As Integer
    
    ' --------------------------
    ' 可修改的参数
    Set sourceWs = ThisWorkbook.Worksheets("原工作表名称") ' 替换为你的源工作表名
    targetHeaders = Array("Column3", "Column5") ' 替换为需要提取的表头名称列表
    headerRow = 1 ' 表头所在行，一般是第1行
    ' --------------------------
    
    ' 创建新工作簿
    Set newWb = Workbooks.Add
    Set newWs = newWb.Sheets(1)
    destCol = 1
    
    ' 遍历目标表头，查找并复制对应列
    For Each header In targetHeaders
        ' 在源工作表表头行查找目标表头
        colIndex = Application.Match(header, sourceWs.Rows(headerRow), 0)
        
        If Not IsError(colIndex) Then
            ' 复制整列到新工作表的当前目标列
            sourceWs.Columns(colIndex).Copy newWs.Columns(destCol)
            destCol = destCol + 1
        Else
            ' 若表头不存在，弹出提示
            MsgBox "未找到表头：" & header, vbExclamation
        End If
    Next header
    
    ' 自动调整新工作表列宽
    newWs.UsedRange.Columns.AutoFit
    
    MsgBox "列提取完成，已保存至新工作簿", vbInformation
End Sub

关键说明 #

• 参数修改区：开头的可修改参数里，替换原工作表名称为你的源表名，把targetHeaders数组里的内容换成你需要提取的所有表头名称（直接按顺序添加即可，比如Array("列A", "列B", "列C")）
• 查找效率：用Application.Match快速定位表头列号，比逐列循环更高效，适合大量列的场景
• 错误处理：如果某个表头在源表中不存在，会弹出提示告知你，不会中断整个提取过程
• 格式保留：复制列时会保留源列的格式、数据有效性等设置，同时自动调整新表的列宽

使用步骤 #

1. 打开源Excel文件，按Alt + F11打开VBA编辑器
2. 右键点击左侧的工作簿名称，选择「插入」→「模块」
3. 将上述代码粘贴到模块窗口中
4. 修改代码开头的参数（源工作表名、目标表头列表）
5. 按F5运行宏，或者回到Excel界面，通过「开发工具」→「宏」选择该宏运行

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