excel vbamacros来匹配来自两个不同工作簿的单元格，并相应地进行复制和粘贴

我有2个工作簿，工作簿A和工作簿B.每个工作簿都有一个表。 工作簿A有2列。 所有三列都填满了。

1. PRODUCT_ID
2. Machine_number和

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

我需要匹配两个工作簿的product_id的单元格。 如果在工作簿A中find的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.

第二个屏幕截图是Workbook A

我不知道为什么发生这种情况，有人可以给我这个理由吗？

………………………………………….. ………………………… 更新

我发现，当product_id（style_number）重复时，问题描述就出现了。

如果product_id GE 55950存在于两个工作簿的两个单元格中。 然后当我执行macros只有一个单元格被检测到。

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

以下是结果的截图。

在屏幕截图中，没有显示机器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 

输出结果如下

Answer 2

我试图复制你的工作簿，我相信他们是这样的

之前 后

代码更改很小，

 Sub UpdateW2() Dim w1 As Worksheet, w2 As Worksheet Dim c As Range, FR As Long Application.ScreenUpdating = False Set w1 = Workbooks("BookOne.xlsm").Worksheets("Sheet1") Set w2 = Workbooks("BookTwo.xlsm").Worksheets("Sheet1") For Each c In w1.Range("D2", w1.Range("D" & 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(, -3) Next c Application.ScreenUpdating = True End Sub