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

excel vba macro to match cells from two different workbooks and copy and paste accordingly

提问by adrian

i have 2 workbooks, workbook A and workbook B. Each workbook has a table. workbook A has 2 columns. All three columns are filled.

我有 2 个工作簿，工作簿 A 和工作簿 B。每个工作簿都有一张桌子。工作簿 A 有 2 列。三列都填满了。

1. product_id
2. Machine_number and

1. 产品编号
2. 机器编号和

Workbook B has the same 2 columns but only one column, Product_id, is filled. The other 1 column is vacant.

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

I need to match the cells of product_id of both workbooks. If the product_id found in workbook A matches workbook B, then the machine number of that product id should be copied from workbook A to workbook B.

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

I have performed this using this code:

我已使用此代码执行此操作：

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

There is a cell that says "machine 4" in product number column. This cell does not get copied and pasted alongside the corresponding product_id value in workbook B.

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

The rest of the machine numbers for the product ids get copied and pasted accordingly.

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

These are the screenshots of results

这些是结果的截图

The first screenshot is Workbook B

第一个截图是工作簿B

The second screenshot is Workbook A

第二个屏幕截图是工作簿 A

I have no idea why this happens, can someone please give me the reason for this?

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

................................................................................ UPDATE

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

I found that the issue ive descriped in the question arises when the product_id(style_number) repeats.

我发现问题中描述的问题出现在 product_id(style_number) 重复时。

Say if product_id GE 55950 is present in 2 cells,in both workbooks. Then when i execute the macro only one of the cells is detected.

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

I tried the coding in both answers but neither solved this problem.

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

Below is a screenshot of the results.

下面是结果的屏幕截图。

In the screenshots the cell with machine 7 is not shown. Can someone tell me why this happens?

在屏幕截图中，没有显示带有机器 7 的单元格。有人能告诉我为什么会这样吗？

采纳答案by Vasily

try this

尝试这个

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

UPDATE AGAINST NEW REQUIREMENTS

针对新要求的更新

use this

用这个

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

output results below

输出结果如下

回答by Davesexcel

I tried to replicate your workbooks, I believe they go something like this

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

Before After

之前 之后

Code changes are minor,

代码改动很小，

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