VBA按匹配表头跨工作表复制粘贴数据问题求助

我是VBA新手，自学写了一段代码，想实现按相同表头在工作表间复制粘贴数据。源表「Template」有30多列，包含公式、文本和日期，需要把其中7列数据复制到目标表「Prior Month」，两张表的表头都在第8行。现在代码只能复制第一列，其他匹配表头的列没法正常复制，附上代码求排查修复，希望实现按匹配表头复制粘贴值，把所有目标数据都导过去。

原代码：

Sub pullData()

Dim header_count As Integer
Dim row_count As Integer
Dim col_count As Integer
Dim i As Integer
Dim j As Integer
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = ThisWorkbook.Sheets("Template")
Set ws2 = ThisWorkbook.Sheets("Prior Month")

ws2.Activate

header_count = WorksheetFunction.CountA(Range("A8", Range("A8").End(xlToRight)))
ws1.Activate
col_count = WorksheetFunction.CountA(Range("A8", Range("A8").End(xlToRight)))
row_count = WorksheetFunction.CountA(Range("A8", Range("A8").End(xlDown)))

For i = 1 To header_count
    j = 1
    Do While j <= col_count
        If ws2.Cells(1, j) = ws1.Cells(1, j).Text Then
            ws1.Range(Cells(1, j), Cells(row_count, j)).Copy
            ws2.Cells(1, j).PasteSpecial xlPasteValues
            Application.CutCopyMode = False
            j = col_count
        End If
        j = j + 1
    Loop
Next i

With ws2
    .Activate
    .Cells(1, i).Select
End With

End Sub

问题排查： #

1. 表头行引用错误：代码里用ws2.Cells(1, j)和ws1.Cells(1, j)判断表头，但实际表头在第8行，完全找错了比对的行
2. 循环逻辑混乱：外层循环遍历目标表列，但内层找到匹配后直接强制跳出循环，且没有对应目标表的列进行粘贴，只处理了第一列就停了
3. 未限定工作表的Range：比如Range("A8", ...)没有指定所属工作表，依赖Activate切换，容易导致引用错误
4. 数据行计算不准：用CountA计算行数会跳过空行，导致部分数据被遗漏

修复后的代码： #

Sub pullData()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim targetCol As Integer, sourceCol As Integer
    Dim lastSourceRow As Long, lastTargetCol As Long, lastSourceCol As Long
    
    ' 指定源表和目标表，避免依赖Activate切换
    Set wsSource = ThisWorkbook.Sheets("Template")
    Set wsTarget = ThisWorkbook.Sheets("Prior Month")
    
    ' 获取目标表第8行的最后一个表头列
    lastTargetCol = wsTarget.Cells(8, wsTarget.Columns.Count).End(xlToLeft).Column
    ' 获取源表第8行的最后一个表头列
    lastSourceCol = wsSource.Cells(8, wsSource.Columns.Count).End(xlToLeft).Column
    ' 获取源表数据区域的最后一行（从A列往上找，避免空行干扰）
    lastSourceRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历目标表的每一个表头列
    For targetCol = 1 To lastTargetCol
        Dim targetHeader As String
        targetHeader = wsTarget.Cells(8, targetCol).Text
        
        ' 在源表中查找匹配的表头
        For sourceCol = 1 To lastSourceCol
            If wsSource.Cells(8, sourceCol).Text = targetHeader Then
                ' 复制源表该列的有效数据（从第9行到最后一行）到目标表对应列
                wsSource.Range(wsSource.Cells(9, sourceCol), wsSource.Cells(lastSourceRow, sourceCol)).Copy
                wsTarget.Cells(9, targetCol).PasteSpecial xlPasteValues
                Application.CutCopyMode = False
                Exit For ' 找到匹配后退出内层循环，提升效率
            End If
        Next sourceCol
    Next targetCol
    
    ' 可选：定位到目标表起始位置
    wsTarget.Activate
    wsTarget.Cells(1, 1).Select
End Sub

修复说明： #

• 所有Range都绑定到对应工作表，彻底避免因激活工作表导致的引用错误
• 统一使用第8行作为表头行，修正原代码的表头行引用错误
• 循环逻辑改为：遍历目标表每个表头，在源表找到匹配后复制对应列数据，确保所有匹配列都能被处理
• 用End(xlUp)获取最后一行数据，避免空行导致的数据遗漏
• 从第9行开始复制粘贴，不会覆盖表头

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