Compare and copy adjacent cell if cells match of the same field in 2 Separate Worksheets

[tkoby11]

Between 2 versions of the same spreadsheets (with some new data each new successive version), where column B cells or "Description" field are the same I want to copy the adjacent cell value (Column A or "Code") from Column A in sheet 1 to column A in sheet 2.

In worksheet 1, I have:

column A column B

Code	Description
KS0001	A Los Vinateros Bravos, Pipeno Blanco 2020 1L
KS0002	Adrien Renoir, Le Terroir Extra Brut NV

In worksheet 2, I want to copy the text in the column "Code" for the same row where the Description is the same:

column A column B

Code	Description
(I need KS0002 here)	Adrien Renoir, Le Terroir Extra Brut NV
KSxxxx	Adroît, Mourvedre 2019

 

[mumps]

Try:

Sub CopyCode()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcRng As Range, WB As Workbook, srcWB As Workbook, desWB As Workbook
    Set desWB = ThisWorkbook
    For Each WB In Workbooks
        If WB.Name <> desWB.Name Then
            Set srcWB = Workbooks(WB.Name)
        End If
    Next WB
    Set srcWS = srcWB.Sheets("Sheet1")
    Set desWS = desWB.Sheets("Sheet1")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 10).Value
    Set srcRng = desWS.Range("B2", desWS.Range("B" & Rows.Count).End(xlUp))
    For i = 1 To UBound(v)
        If Not IsError(Application.Match(v(i, 2), srcRng, 0)) Then
            x = Application.Match(v(i, 2), srcRng, 0)
            With desWS
                .Range("A" & x + 1) = v(i, 1)
                .Range("C" & x + 1).Resize(, 2).Value = Array(v(i, 3), v(i, 4))
                .Range("H" & x + 1).Resize(, 3).Value = Array(v(i, 8), v(i, 9), v(i, 10))
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[tkoby11]

Sub CopyCode() Application.ScreenUpdating = False Dim v As Variant, i As Long, srcRng As Range, WB As Workbook, srcWB As Workbook, desWB As Workbook Set desWB = ThisWorkbook For Each WB In Workbooks If WB.Name <> desWB.Name Then Set srcWB = Workbooks(WB.Name) End If Next WB Set srcWS = srcWB.Sheets("Sheet1") Set desWS = desWB.Sheets("Sheet1") v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 10).Value Set srcRng = desWS.Range("B2", desWS.Range("B" & Rows.Count).End(xlUp)) For i = 1 To UBound(v) If Not IsError(Application.Match(v(i, 2), srcRng, 0)) Then x = Application.Match(v(i, 2), srcRng, 0) With desWS .Range("A" & x + 1) = v(i, 1) .Range("C" & x + 1).Resize(, 2).Value = Array(v(i, 3), v(i, 4)) .Range("H" & x + 1).Resize(, 3).Value = Array(v(i, 8), v(i, 9), v(i, 10)) End With End If Next i Application.ScreenUpdating = True End Sub

Awesome, thank you, that worked!

Anyway I can send you a thank you, do you like wine?

 

[mumps]

You are very welcome. Your "thanks" are enough.

 

[tkoby11]

You are very welcome. Your "thanks" are enough.

Very kind of you and thank you so much!

 

[mumps]

My pleasure.

 

[tkoby11]

Hi @mumps, can you take a look, it seems like the macro is no longer working. Did I do something to knock it off course? What's the best way step by step to run it in a new sheet if I am just missing a step in the new file?

The 3 source files with the macro are in this link:

One Drive

Microsoft OneDrive

onedrive.live.com

 

[mumps]

Can you give me a few examples oh how it is not working?

 

[tkoby11]

Steps I was taking:

I save the new file as an .XLSM after formatting it to match the previous versions so it knows to look for the same exact data
(Kellogg NC 2.21.22 formatted)

I then open the visual basic editor and check that the module is there

Then under the macros I run the macro (CopyCode)

Then I get the following error in the attached image.

 

[mumps]

That means you have something either before

Sub CopyCode()

or after

End Sub

Which line of code is highlighted? If the highlighted line is outside the sub as I described, delete it.

 

[tkoby11]

Ok, I deleted the old modules that were causing the error and put in a new one and used the last set of code you gave me that worked. The error is gone, but now nothing populates in the sheets like it used to.