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

Question

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

1. product_id
2. Machine_number and

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

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.

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.

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

These are the screenshots of results

The first screenshot is Workbook B

The second screenshot is Workbook 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.

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.

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?

Answer 1

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

Answer 2

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