Excel 2016 VBA多条件跨工作簿数据提取问题求助

先理清楚你的需求，避免混淆：你要在**工作簿2（当前运行代码的工作簿，即ThisWorkbook）**的MainPage工作表中，找到满足以下两个条件的行：

• 工作簿2的A列值 = 工作簿1（你选择打开的外部文件）的C列值
• 工作簿2的B列值 = 工作簿1的D列值
  然后把工作簿1对应行的B列数据，写入工作簿2对应行的D列。

你的原代码存在几个关键问题，导致无法实现需求：

• 工作表的Source和Target搞反了，列匹配逻辑完全不符合你的需求
• 最后一行（LastRow）的计算逻辑错误，引用了错误工作表的行数
• 循环中的列判断条件和需求不匹配

修正后的完整代码 #

Sub AmandaTest()
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim vFile As Variant
    Dim lastRowSource As Long, lastRowTarget As Long
    Dim i As Long, x As Long
    
    ' 设置目标工作簿（当前运行代码的工作簿，即工作簿2）
    Set wbTarget = ThisWorkbook
    Set wsTarget = wbTarget.Sheets("MainPage")
    
    ' 选择源工作簿（工作簿1）
    vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
        1, "Select One File To Open", , False)
    If vFile = "" Then Exit Sub ' 用户未选择文件则退出
    
    ' 打开并设置源工作簿
    Set wbSource = Workbooks.Open(vFile)
    Set wsSource = wbSource.Sheets("Sheet1")
    
    ' 获取两个工作表的最后数据行（修正原代码的行数引用错误）
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row ' 按工作簿1的C列取最后行
    
    ' 遍历目标工作簿的每一行，匹配源工作簿的数据
    For i = 1 To lastRowTarget
        ' 重置D列值（可选：清除原有匹配结果）
        wsTarget.Range("D" & i).Value = ""
        
        ' 遍历源工作簿的行，寻找双条件匹配项
        For x = 1 To lastRowSource
            ' 匹配条件：工作簿2的A列 = 工作簿1的C列，且工作簿2的B列 = 工作簿1的D列
            If wsTarget.Range("A" & i).Value = wsSource.Range("C" & x).Value And _
               wsTarget.Range("B" & i).Value = wsSource.Range("D" & x).Value Then
               
                ' 将工作簿1的B列数据写入工作簿2的D列
                wsTarget.Range("D" & i).Value = wsSource.Range("B" & x).Value
                Exit For ' 找到匹配项后退出内层循环，提升效率
            End If
        Next x
    Next i
    
    ' 可选：关闭源工作簿（如果不需要保留打开状态）
    ' wbSource.Close SaveChanges:=False
End Sub

关键改动说明 #

• 工作表命名修正：把原代码混乱的wsS/wsT改成wsSource/wsTarget，更清晰区分数据来源和目标
• LastRow计算修正：分别基于自身工作表的行数计算最后数据行，避免跨表引用错误
• 匹配条件修正：严格按照你的需求，对应工作簿2的A/B列和工作簿1的C/D列进行双条件判断
• 效率优化：找到匹配项后用Exit For跳出内层循环，避免不必要的遍历
• 可选重置操作：先清空目标列的原有数据，避免残留旧值

额外优化建议（处理大数据量） #

如果你的数据量较大（比如上千行），双重循环会比较慢，建议使用Dictionary来存储源数据的匹配键值对，把时间复杂度从O(n*m)降到O(n)：

Sub AmandaTest_WithDictionary()
    Dim wbSource As Workbook, wbTarget As Workbook
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim vFile As Variant
    Dim lastRowSource As Long, lastRowTarget As Long
    Dim i As Long
    Dim matchDict As Object
    
    Set matchDict = CreateObject("Scripting.Dictionary")
    
    ' 设置目标工作簿
    Set wbTarget = ThisWorkbook
    Set wsTarget = wbTarget.Sheets("MainPage")
    
    ' 选择源工作簿
    vFile = Application.GetOpenFilename("Excel-files,*.xlsx", _
        1, "Select One File To Open", , False)
    If vFile = "" Then Exit Sub
    
    Set wbSource = Workbooks.Open(vFile)
    Set wsSource = wbSource.Sheets("Sheet1")
    
    lastRowSource = wsSource.Cells(wsSource.Rows.Count, "C").End(xlUp).Row
    ' 将源数据的双条件组合作为字典键，对应B列值作为字典值
    For i = 1 To lastRowSource
        Dim key As String
        key = wsSource.Range("C" & i).Value & "|" & wsSource.Range("D" & i).Value
        If Not matchDict.Exists(key) Then
            matchDict(key) = wsSource.Range("B" & i).Value
        End If
    Next i
    
    ' 遍历目标工作簿，快速匹配
    lastRowTarget = wsTarget.Cells(wsTarget.Rows.Count, "A").End(xlUp).Row
    For i = 1 To lastRowTarget
        key = wsTarget.Range("A" & i).Value & "|" & wsTarget.Range("B" & i).Value
        If matchDict.Exists(key) Then
            wsTarget.Range("D" & i).Value = matchDict(key)
        Else
            wsTarget.Range("D" & i).Value = ""
        End If
    Next i
    
    ' wbSource.Close SaveChanges:=False
    Set matchDict = Nothing
End Sub

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