基于A列值与指定列标题的跨工作簿数据复制宏问题排查

需求说明 #

• 从源工作簿向目标工作簿复制数据，匹配规则：
  1. 以目标工作簿A列第8行及以后的值为匹配键，若该值在源工作簿中找不到，或值本身为“-”，则对应匹配标题列填入“-”
  2. 按列标题匹配：源工作簿仅包含需要复制的标题，目标工作簿列更多且顺序与源文件不同
  3. 支持重复值：目标A列有重复值时，对应行都要粘贴数据

原代码问题分析 #

1. 拼写与语法错误：
   • 变量名拼写错误：srcWrokbook→srcWorkbook，destWorkbok→destWorkbook
   • 单元格引用错误：srcSheetCells→srcSheet.Cells
   • 对象变量声明错误：Dim srcSheet=... 应该用Set关键字
2. 逻辑错误（导致错误13：类型不匹配）：
   • 遍历目标行起始位置错误：原代码从A2开始，不符合需求的第8行
   • 标题匹配逻辑倒置：应该遍历目标标题找源标题的对应位置，而非反过来
   • Application.Match直接传入二维数组导致类型不匹配，需逐个标题匹配
   • 未处理“匹配不到”或目标值为“-”的场景，未填入要求的“-”
   • 循环内重复声明变量，降低运行效率

修正后的完整代码 #

Option Explicit

Sub CopyMatchedData()
    Dim srcWorkbook As Workbook
    Dim srcSheet As Worksheet
    Dim srcLastRow As Long, srcLastCol As Long
    Dim srcHeaders As Variant
    Dim srcData As Variant
    Dim destWorkbook As Workbook
    Dim destSheet As Worksheet
    Dim destLastRow As Long, destLastCol As Long
    Dim destHeaders As Variant
    Dim destRow As Long
    Dim destKey As Variant
    Dim srcMatchRow As Variant
    Dim headerIndex As Long
    Dim srcColIndex As Variant
    
    ' 打开源工作簿
    Set srcWorkbook = Workbooks.Open("M:\Desktop\Data.xlsm")
    Set srcSheet = srcWorkbook.Worksheets("Data")
    
    ' 获取源数据范围及标题
    srcLastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
    srcLastCol = srcSheet.Cells(1, srcSheet.Columns.Count).End(xlToLeft).Column
    srcHeaders = srcSheet.Range("A1", srcSheet.Cells(1, srcLastCol)).Value
    srcData = srcSheet.Range("A1", srcSheet.Cells(srcLastRow, srcLastCol)).Value
    
    ' 定位目标工作簿及工作表
    Set destWorkbook = ThisWorkbook
    Set destSheet = destWorkbook.Worksheets("Sheet1")
    
    ' 获取目标数据范围及标题
    destLastRow = destSheet.Cells(destSheet.Rows.Count, "A").End(xlUp).Row
    destLastCol = destSheet.Cells(1, destSheet.Columns.Count).End(xlToLeft).Column
    destHeaders = destSheet.Range("A1", destSheet.Cells(1, destLastCol)).Value
    
    ' 遍历目标A列第8行及以后的行
    For destRow = 8 To destLastRow
        destKey = destSheet.Cells(destRow, "A").Value
        
        ' 初始化当前行为"-"，确保未匹配场景符合要求
        destSheet.Range(destSheet.Cells(destRow, 1), destSheet.Cells(destRow, destLastCol)).Value = "-"
        
        ' 跳过空值
        If IsEmpty(destKey) Then GoTo NextRow
        
        ' 匹配源数据中的键值
        srcMatchRow = Application.Match(destKey, srcSheet.Range("A:A"), 0)
        
        ' 如果匹配到有效行，复制对应列数据
        If Not IsError(srcMatchRow) Then
            For headerIndex = 1 To UBound(destHeaders, 2)
                srcColIndex = Application.Match(destHeaders(1, headerIndex), srcHeaders, 0)
                If Not IsError(srcColIndex) Then
                    destSheet.Cells(destRow, headerIndex).Value = srcData(srcMatchRow, srcColIndex)
                End If
            Next headerIndex
        End If
        
NextRow:
    Next destRow
    
    ' 关闭源工作簿（按需调整是否保存）
    srcWorkbook.Close SaveChanges:=False
    MsgBox "数据复制完成！", vbInformation
End Sub

代码说明 #

• 批量读取源数据到数组，大幅提升运行效率
• 遍历目标行前先将整行设为“-”，确保未匹配、值为“-”的场景直接符合要求
• 修正标题匹配逻辑：遍历目标标题，找到对应源标题列索引后复制数据，解决类型不匹配问题
• 新增空值跳过逻辑，避免无意义匹配操作
• 末尾添加源工作簿关闭逻辑，可根据需求调整是否保存源文件

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