VBA宏问题：按表头匹配复制Workbook2指定列数据失败

核心问题拆解 #

1. 仅复制最后匹配列：嵌套循环中每次匹配都会覆盖剪贴板内容，且未及时执行粘贴，最终仅保留最后一次复制的列；同时未在找到匹配后退出内层循环，可能出现重复匹配（若存在重复表头）。
2. 复制整列而非表头下数据：使用EntireColumn.Copy复制了整列（包含表头和空白区域），未精准定位表头下方的有效数据范围。
3. 隐藏逻辑错误：IsWorkBookOpen的判断逻辑颠倒，当前代码会在目标工作簿已打开时提示未打开，导致流程完全错误。

修正后的完整代码 #

主宏代码 #

Sub TEST_PL()
    Application.ScreenUpdating = False
    
    ' 定义目标工作表（当前工作簿的RAW表）
    Dim wsTarget As Worksheet
    Set wsTarget = ThisWorkbook.Sheets("RAW")
    
    ' 获取源工作簿（带后缀的SIEG报表）
    Dim wbSource As Workbook
    Set wbSource = getWorkBookByName("Relatorio Xml Cofre SIEG - ")
    
    ' 检查源工作簿是否存在
    If wbSource Is Nothing Then
        MsgBox "Planilha do SIEG não esta aberta!", vbInformation
        GoTo Cleanup
    End If
    
    ' 定义表头区域
    Dim rngTargetHeaders As Range, rngSourceHeaders As Range
    Set rngTargetHeaders = wsTarget.Range("A1:F1") ' 目标工作簿表头
    Set rngSourceHeaders = wbSource.Sheets("Relátorio de Xml's - Cofre").Range("A3:Q3") ' 源工作簿表头
    
    Dim cellTarget As Range, cellSource As Range
    Dim lastRowSource As Long, lastRowTarget As Long
    Dim rngSourceData As Range
    
    For Each cellTarget In rngTargetHeaders
        ' 遍历源表头寻找匹配项
        For Each cellSource In rngSourceHeaders
            ' 不区分大小写匹配表头文本
            If StrComp(cellTarget.Value, cellSource.Value, vbTextCompare) = 0 Then
                ' 定位源数据：表头下第一行到该列最后一个非空单元格
                lastRowSource = cellSource.Parent.Cells(Rows.Count, cellSource.Column).End(xlUp).Row
                If lastRowSource > cellSource.Row Then ' 确保有数据可复制
                    Set rngSourceData = cellSource.Offset(1, 0).Resize(lastRowSource - cellSource.Row, 1)
                    
                    ' 定位目标粘贴位置：目标列最后一个非空单元格的下一行
                    lastRowTarget = wsTarget.Cells(Rows.Count, cellTarget.Column).End(xlUp).Row
                    ' 若目标列只有表头，从表头下第一行开始粘贴
                    If lastRowTarget < cellTarget.Row Then lastRowTarget = cellTarget.Row
                    
                    ' 直接复制粘贴到目标位置
                    rngSourceData.Copy Destination:=wsTarget.Cells(lastRowTarget + 1, cellTarget.Column)
                End If
                
                Exit For ' 找到匹配后退出内层循环，避免重复处理
            End If
        Next cellSource
    Next cellTarget

Cleanup:
    Application.ScreenUpdating = True
End Sub

辅助函数（优化后） #

Option Explicit

Function getWorkBookByName(SearchStr As String) As Workbook
    Dim wb As Workbook
    For Each wb In Workbooks
        If InStr(1, wb.Name, SearchStr, vbTextCompare) > 0 Then
            Set getWorkBookByName = wb
            Exit Function
        End If
    Next
    ' 未找到时返回Nothing，供主宏判断
    Set getWorkBookByName = Nothing
End Function

Function IsWorkBookOpen(wbName As String) As Boolean
    Dim xWb As Workbook
    On Error Resume Next
    Set xWb = Application.Workbooks(wbName)
    On Error GoTo 0 ' 恢复默认错误处理
    IsWorkBookOpen = Not xWb Is Nothing
End Function

关键优化说明 #

• 修复工作簿判断逻辑：直接通过getWorkBookByName的返回值判断源工作簿是否打开，替代原逻辑颠倒的判断，流程更可靠。
• 精准数据范围控制：
  • 源数据：用End(xlUp)定位列最后一行非空单元格，仅复制表头下方的有效数据，避免整列复制冗余内容。
  • 目标位置：自动找到目标列的最后一行数据，从下一行开始粘贴，不会覆盖已有内容。
• 高效匹配逻辑：找到匹配表头后立即退出内层循环，避免无效遍历；使用StrComp实现不区分大小写的表头匹配，兼容性更强。
• 代码健壮性：添加Cleanup标签确保ScreenUpdating始终恢复；明确指定ThisWorkbook避免ActiveWorkbook的歧义。

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