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]

In order for the macro to work, the source file cannot have any blank cells in column A. In other words, each description in column B must have a code in column A. Fill in the missing codes and try the macro again.

 

[tkoby11]

Ok, it's working, BUT the data is going backwards...when I run the macro the new file's blanks are overriding the matches in what should be the source file. So the source file starts with a full column A, then when I run the file while in the new file, it copies blanks over to the old file to the match in column B. Am I doing a step backwards or is it the language?


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

 

[mumps]

Most likely the macro exists in both files. Make sure that the destination file is the active workbook and that you run the macro in the destination file, not the one in the source file.

 

[tkoby11]

Thanks, I figured it out the last time with the flow, I also had a few things in the sheet causing an error I adjusted and fixed. It has worked seamlessly since. Now I have a new error, can you help me fix this one or let me know if I am doing anything wrong?

With both files open and the new file the active file, I get the following error

run-time error '9':
Subscript out of range

when I try to debug it, VB highlights this script in the code:

Set desWS = desWB.Sheets("Sheet1")

I put the 2 sheets I am using in this shared drive:

Excel Problems

 

[mumps]

Does the workbook containing the macro (desWB) have a sheet named "Sheet1"?

 

[tkoby11]

Shoot, that was it, thank you again!

 

[mumps]

My pleasure.

 

[Gmoney69]

Try:

Sub CopyCode()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcRng As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).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)
            desWS.Range("A" & x + 1) = v(i, 1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Try:

Sub CopyCode()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcRng As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).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)
            desWS.Range("A" & x + 1) = v(i, 1)
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Any way you could post this same thing that also copies cell color?

 

[mumps]

Try:

Sub CopyCode()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcRng As Range, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).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)
                .Value = v(i, 1)
                .Interior.ColorIndex = srcWS.Range("B" & i + 1).Interior.ColorIndex
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[Gmoney69]

Try:

Sub CopyCode()
    Application.ScreenUpdating = False
    Dim v As Variant, i As Long, srcRng As Range, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Resize(, 2).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)
                .Value = v(i, 1)
                .Interior.ColorIndex = srcWS.Range("B" & i + 1).Interior.ColorIndex
            End With
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

Works great. Thanks. Sorry to do this but I have one more question. Could you also make it so it has to match 2 adjacent cells for it to copy so B and C rather than just B?