使用VBA按匹配表头从源工作簿导入指定列至目标工作簿

我有两个表头名称一致的Excel工作簿，需要通过VBA代码根据表头名称，将源工作簿中的指定列数据导入/复制到目标工作簿，替换目标工作簿对应列的原有数据。

示例 #

源工作簿（Source WB）

目标工作簿（Target WB）

期望输出

我尝试了以下代码，但无法更新目标工作簿：

Sub Pull_finalise_columns()
    On Error Resume Next
    Const Adopenstatic = 3
    Const adlockoptimistic = 3
    Const adcmdtext = &H1
    
    Dim conn As Object
    Dim sf As Object            'setting up source file
    Dim filename As String
    Dim filepath As String

    filepath = "D:\"           'location where source file is located
    filename = "Test.xlsm"           'name of sourcefile
    
    Set conn = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    
    conn.Open "provider=Microsoft.ACE.OLEDB.12.0;" & _
                "data source=" & filepath & ";" & _
                "extended properties=""Excel 16.0; HDR=yes"""
    
    sf.Open "select[File Name],[$business Name],[$Business Description],[Personal Identifier Special Category],[Data Treatment],[Personal Identifier Type],[Primary Key]," _
             & [Security Classification Candidate], [PCI-DSS], [Pi] _
             & [" & filename & "], conn, Adopenstatic, adlockoptimistic, adcmdtext
                
    Worksheets("sheet1").Range("a1").CopyFromRecordset sf
    sf.Close
    conn.Close
End Sub

这段代码存在多个问题：

• On Error Resume Next 会屏蔽所有错误，导致无法定位问题根源
• ADODB连接字符串错误：data source 需要指定完整的文件路径（filepath & filename），而非单独的文件夹路径
• 变量混淆：定义了rs作为Recordset对象，但实际使用了未初始化的sf变量
• SQL语句语法错误：字段引用格式错误，字符串拼接逻辑混乱，且未指定源数据所在的工作表，最后错误地将文件名拼接到SQL语句中
• 未处理表头匹配：CopyFromRecordset仅复制数据行，不会按目标表头的列顺序同步数据

以下是直接通过工作表对象操作的VBA代码，更直观且易维护：

Sub CopyColumnsByHeader()
    ' 配置参数
    Dim sourceFilePath As String
    Dim sourceFileName As String
    Dim sourceSheetName As String
    Dim targetSheetName As String
    
    sourceFilePath = "D:\"          ' 源文件所在文件夹
    sourceFileName = "Test.xlsm"    ' 源文件名
    sourceSheetName = "Sheet1"      ' 源数据所在工作表
    targetSheetName = "Sheet1"      ' 目标数据所在工作表
    
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim targetWS As Worksheet
    Dim targetHeaders As Range
    Dim headerCell As Range
    Dim sourceHeaderRow As Range
    Dim sourceCol As Range
    Dim targetCol As Integer
    Dim lastRowSource As Long
    Dim lastRowTarget As Long
    
    ' 打开源工作簿（后台打开，不显示）
    Set sourceWB = Workbooks.Open(Filename:=sourceFilePath & sourceFileName, ReadOnly:=True, Visible:=False)
    Set sourceWS = sourceWB.Worksheets(sourceSheetName)
    Set targetWS = ThisWorkbook.Worksheets(targetSheetName)
    
    ' 获取目标工作表的表头区域（假设表头在第1行）
    Set targetHeaders = targetWS.Range("A1", targetWS.Cells(1, targetWS.Columns.Count).End(xlToLeft))
    ' 获取源工作表的表头行（假设表头在第1行）
    Set sourceHeaderRow = sourceWS.Range("A1", sourceWS.Cells(1, sourceWS.Columns.Count).End(xlToLeft))
    
    ' 遍历每个目标表头，匹配源数据列
    For Each headerCell In targetHeaders
        ' 在源表头中查找匹配的列
        Set sourceCol = sourceHeaderRow.Find(What:=headerCell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        
        If Not sourceCol Is Nothing Then
            ' 获取源列的最后一行数据行号
            lastRowSource = sourceWS.Cells(sourceWS.Rows.Count, sourceCol.Column).End(xlUp).Row
            ' 获取目标列的列号
            targetCol = headerCell.Column
            
            ' 清空目标列原有数据（保留表头）
            targetWS.Range(targetWS.Cells(2, targetCol), targetWS.Cells(targetWS.Rows.Count, targetCol)).ClearContents
            
            ' 复制源列数据到目标列（从第2行开始）
            sourceWS.Range(sourceWS.Cells(2, sourceCol.Column), sourceWS.Cells(lastRowSource, sourceCol.Column)).Copy _
                Destination:=targetWS.Cells(2, targetCol)
        End If
    Next headerCell
    
    ' 关闭源工作簿，不保存
    sourceWB.Close SaveChanges:=False
    Set sourceWB = Nothing
    
    MsgBox "数据更新完成！", vbInformation
End Sub

1. 参数配置：开头可根据实际情况修改源文件路径、文件名、工作表名称
2. 后台打开源文件：Visible:=False 避免打开源文件时干扰操作，ReadOnly:=True 防止源文件被锁定
3. 表头匹配：通过Find方法根据表头名称精准匹配源数据列，无需关心列的位置
4. 数据替换：先清空目标列原有数据（保留表头），再复制源列数据覆盖
5. 资源释放：关闭源工作簿并释放对象，避免内存占用

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