如何使用Excel VBA按首行列名筛选所需列并复制到其他工作表

• 先提前整理好需要保留的列名清单，写入固定数组，后续调整保留列只需要修改数组内容即可，无需改动核心逻辑
• 遍历原始数据表表头行的所有单元格，匹配单元格值是否属于预设的保留列清单
• 两种实现路径可按需选择：
  • 方案1（推荐）：将匹配到的列整列复制到新建空白工作表，完全不修改原始表数据，避免误删原始导出数据
  • 方案2：直接在原始表删除未匹配到的列，操作时必须从最右侧列往左侧遍历删除，否则列索引动态变化会导致漏删列

方案1：提取目标列到新工作表（更安全） #

Sub 按列名提取目标列()
    ' 按需修改此处的保留列名即可
    Dim keepCols As Variant
    keepCols = Array("Customer", "Product", "Color")
    
    Dim srcSheet As Worksheet, resSheet As Worksheet
    Dim lastCol As Long, i As Long, resCol As Long
    
    ' 绑定原始数据表，默认取当前活动工作表，也可写为Set srcSheet = Sheets("你的原始表名")
    Set srcSheet = ActiveSheet
    ' 新建工作表存储结果
    Set resSheet = ThisWorkbook.Worksheets.Add
    resCol = 1
    
    ' 获取原始表表头行的最大列号
    lastCol = srcSheet.Cells(1, srcSheet.Columns.Count).End(xlToLeft).Column
    
    ' 遍历原始表所有列
    For i = 1 To lastCol
        ' 匹配列名是否在保留清单中
        If Not IsError(Application.Match(srcSheet.Cells(1, i).Value, keepCols, 0)) Then
            ' 匹配成功则复制整列到结果表
            srcSheet.Columns(i).Copy resSheet.Columns(resCol)
            resCol = resCol + 1
        End If
    Next i
    
    ' 自动调整结果表列宽
    resSheet.Cells.EntireColumn.AutoFit
    MsgBox "提取完成，结果已存入工作表：" & resSheet.Name
End Sub

方案2：直接在原始表删除多余列 #

Sub 删除非目标列()
    Dim keepCols As Variant
    keepCols = Array("Customer", "Product", "Color")
    
    Dim srcSheet As Worksheet
    Dim lastCol As Long, i As Long
    
    Set srcSheet = ActiveSheet
    lastCol = srcSheet.Cells(1, srcSheet.Columns.Count).End(xlToLeft).Column
    
    ' 从最右列往左遍历删除，避免列索引变动导致漏删
    For i = lastCol To 1 Step -1
        If IsError(Application.Match(srcSheet.Cells(1, i).Value, keepCols, 0)) Then
            srcSheet.Columns(i).Delete
        End If
    Next i
    
    MsgBox "多余列删除完成"
End Sub

• 运行代码前建议先备份原始导出数据，避免操作失误丢失内容
• 代码默认表头在第1行，如果你的表头在其他行，把Cells(1, i)中的数字1改为表头对应的行号即可
• 列名匹配为完全匹配，如需忽略大小写，可将匹配逻辑改为统一转大小写后再比对

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