VBA基于部分文件名跨工作簿匹配复制指定区域数据问题排查

需求说明 #

• 目标工作簿：名称含Table Games Lines关键字（带日期/编号），数据存入Previous Wk (MONDAY)工作表（名称随星期变化）
• 源工作簿：名称含IGTHeadcount关键字（带日期/编号），数据取自Headcount工作表
• 核心任务：通过两工作簿A列内容精确匹配，找到匹配项后，将源工作簿对应行的B:Y区域（不含A列）复制到目标工作簿的对应行

原代码问题点 #

1. 工作表引用错误：原代码中Set wsSource = wb.Sheets("Headcount")未指定为源工作簿wbSource，导致引用混乱
2. 搜索逻辑错误：原代码仅获取单个单元格作为搜索值，未遍历目标工作簿的所有A列待匹配项
3. 复制区域错误：原代码仅复制B列单个单元格，未覆盖需求中的B:Y整区域
4. 变量冗余：wsLookup与wsSource重复引用，无实际意义

修复后的代码 #

Sub FindAndCopyRange()
    Dim wbDest As Workbook, wbSource As Workbook
    Dim wb As Workbook
    Dim wsTarget As Worksheet, wsSourceSheet As Worksheet
    Dim targetLastRow As Long, sourceLastRow As Long
    Dim i As Long, matchRow As Long
    
    ' 定位目标工作簿（含Table Games Lines关键字）
    For Each wb In Workbooks
        If InStr(1, wb.Name, "Table Games Lines", vbTextCompare) > 0 Then
            Set wbDest = wb
            Exit For
        End If
    Next wb
    
    ' 定位源工作簿（含IGTHeadcount关键字）
    For Each wb In Workbooks
        If InStr(1, wb.Name, "IGTHeadcount", vbTextCompare) > 0 Then
            Set wbSource = wb
            Exit For
        End If
    Next wb
    
    ' 检查工作簿是否找到
    If wbDest Is Nothing Or wbSource Is Nothing Then
        MsgBox "未找到目标或源工作簿，请确认两个工作簿已打开", vbCritical
        Exit Sub
    End If
    
    ' 绑定工作表
    Set wsTarget = wbDest.Sheets("Previous Wk (MONDAY)") ' 可根据实际星期修改工作表名
    Set wsSourceSheet = wbSource.Sheets("Headcount")
    
    ' 获取目标表和源表的最后行号
    targetLastRow = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    sourceLastRow = wsSourceSheet.Cells(wsSourceSheet.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历目标表的每一行A列值，去源表匹配
    For i = 2 To targetLastRow ' 假设第1行是表头，从第2行开始处理数据
        ' 跳过空单元格
        If wsTarget.Cells(i, "A").Value <> "" Then
            ' 在源表A列查找精确匹配项
            On Error Resume Next
            matchRow = wsSourceSheet.Columns("A").Find(What:=wsTarget.Cells(i, "A").Value, _
                LookIn:=xlValues, LookAt:=xlWhole).Row
            On Error GoTo 0
            
            ' 找到匹配则复制B:Y区域到目标对应行
            If matchRow > 0 Then
                wsSourceSheet.Range("B" & matchRow & ":Y" & matchRow).Copy _
                    Destination:=wsTarget.Range("B" & i)
                matchRow = 0 ' 重置匹配行号，避免后续误判
            End If
        End If
    Next i
    
    MsgBox "数据复制完成", vbInformation
End Sub

代码说明 #

• 自动识别打开的目标/源工作簿，无需手动指定完整名称
• 遍历目标工作簿所有待匹配行，跳过空单元格提升效率
• 精确匹配A列内容，找到后直接复制B:Y整行区域到目标对应行
• 增加工作簿未找到的错误提示，提升代码鲁棒性

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