vba - excel vba宏匹配来自两个不同工作簿的单元格并相应地复制和粘贴

Question

我有 2 个工作簿，工作簿 A 和工作簿 B。每个工作簿都有一个表。工作簿 A 有 2 列。所有三列均已填充。

1. 产品 ID
2. Machine_number 和

工作簿 B 具有相同的 2 列，但只有一列 Product_id 被填充。另外 1 列是空的。

我需要匹配两个工作簿的product_id 单元格。如果工作簿 A 中找到的 Product_id 与工作簿 B 匹配，则应将该产品 id 的机器编号从工作簿 A 复制到工作簿 B。

我已经使用以下代码执行了此操作:

Sub UpdateW2()

Dim w1 As Worksheet, w2 As Worksheet
Dim c As Range, FR As Long

Application.ScreenUpdating = False

Set w1 = Workbooks("workbookA.xlsm").Worksheets("Sheet1")
Set w2 = Workbooks("workbookB.xlsm").Worksheets("Sheet1")


For Each c In w1.Range("A2", w1.Range("A" & Rows.Count).End(xlUp))
  FR = 0
  On Error Resume Next
  FR = Application.Match(c, w2.Columns("A"), 0)
  On Error GoTo 0
  If FR <> 0 Then w2.Range("C" & FR).Value = c.Offset(, 0)
Next c
Application.ScreenUpdating = True
End Sub

产品编号列中有一个单元格显示“机器 4”。此单元格不会与工作簿 B 中相应的product_id 值一起复制和粘贴。

相应地复制并粘贴产品 ID 的其余机器编号。

这些是结果截图

第一张截图是练习册B

第二张截图是作业簿A

我不知道为什么会发生这种情况，有人可以告诉我原因吗？

...................................................... ......................................更新

我发现当product_id(style_number)重复时，就会出现问题中描述的问题。

假设product_id GE 55950 是否存在于两个工作簿的2 个单元格中。然后，当我执行宏时，仅检测到其中一个单元格。

我尝试了两个答案中的编码，但都没有解决这个问题。

下面是结果的屏幕截图。

在屏幕截图中，未显示带有机器 7 的单元。有人能告诉我为什么会发生这种情况吗？

Answer 1

试试这个

Sub UpdateW2()
    Dim Dic As Object, key As Variant, oCell As Range, i&
    Dim w1 As Worksheet, w2 As Worksheet

    Set Dic = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("workbookA.xlsm").Sheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Sheets("Sheet1")

    i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w1.Range("D2:D" & i)
        If Not Dic.exists(oCell.Value) Then
            Dic.Add oCell.Value, oCell.Offset(, -3).Value
        End If
    Next

    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row

    For Each oCell In w2.Range("A2:A" & i)
        For Each key In Dic
            If oCell.Value = key Then
                oCell.Offset(, 2).Value = Dic(key)
            End If
        Next
    Next
End Sub

根据新要求进行更新

用这个

Sub UpdateW2()
    Dim key As Variant, oCell As Range, i&, z%
    Dim w1 As Worksheet, w2 As Worksheet
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dim Dic2 As Object: Set Dic2 = CreateObject("Scripting.Dictionary")
    Set w1 = Workbooks("workbookA.xlsm").Sheets("Sheet1")
    Set w2 = Workbooks("workbookB.xlsm").Sheets("Sheet1")
    '-------------------------------------------------------------------------
    'get the last row for w1
    i = w1.Cells.SpecialCells(xlCellTypeLastCell).Row
    '-------------------------------------------------------------------------
    ' fill dictionary with data for searching
    For Each oCell In w1.Range("D2:D" & i)
        'row number for duplicates
        z = 1: While Dic.exists(oCell.Value & "_" & z): z = z + 1: Wend
        'add data with row number to dictionary
        If Not Dic.exists(oCell.Value & "_" & z) Then
            Dic.Add oCell.Value & "_" & z, oCell.Offset(, -3).Value
        End If
    Next
    '-------------------------------------------------------------------------
    'get the last row for w2
    i = w2.Cells.SpecialCells(xlCellTypeLastCell).Row
    '-------------------------------------------------------------------------
    'fill "B" with results
    For Each oCell In w2.Range("A2:A" & i)
        'determinate row number for duplicated values
        z = 1: While Dic2.exists(oCell.Value & "_" & z): z = z + 1: Wend
        'search
        For Each key In Dic
            If oCell.Value & "_" & z = key Then
                oCell.Offset(, 2).Value = Dic(key)
            End If
        Next
        'correction of the dictionary in case
        'when sheet "A" has less duplicates than sheet "B"
        If oCell.Offset(, 2).Value = "" Then
            Dic2.RemoveAll: z = 1
            For Each key In Dic
                If oCell.Value & "_" & z = key Then
                    oCell.Offset(, 2).Value = Dic(key)
                End If
            Next
        End If
        'add to dictionary already passed results for
        'the next duplicates testing
        If Not Dic2.exists(oCell.Value & "_" & z) Then
            Dic2.Add oCell.Value & "_" & z, ""
        End If
    Next
End Sub

输出结果如下