Match and copy.

[wildti]

Hi I have 2 sheets in a workbook, I want to compare column A in Sheet 1 with Column A in Sheet 2 (they contain company names) If there are any matches I want it to copy a value from the corresponding cell in column B Sheet 2 to a cell in sheet A also corresponding with the match.

I can get this to work if I specify which value to search for but I need it to look for matches itself.

Any help would be great its a bit beyond my ability.

[holycow]

Which list would be longer, Sheet1 ColumnA or Sheet2 ColumnA? Would either list contain duplicate entries?

[wildti]

Hi Thanks the list in Sheet2 is longer. there will me no duplicate entries.
Many Thanks

[holycow]

Give this a try

Sub test()
    Dim a As Long, b As Long, x As Long
    Dim aa As Range, bb As Range
    a = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    b = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
    Set aa = Sheet1.Range("A1:A" & a)
    Set bb = Sheet2.Range("A1:A" & b)
    On Error Resume Next
        For Each Cell In bb
            x = aa.Find(Cell).Row
            Sheet1.Range("B" & x) = Cell.Offset(, 1)
        Next
    On Error GoTo 0
End Sub

[holycow]

Amended slightly

Sub test()
    Dim a As Long, b As Long
    Dim aa As Range, bb As Range
    Application.ScreenUpdating = False
    a = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    b = Sheet2.Range("A" & Rows.Count).End(xlUp).Row
    Set aa = Sheet1.Range("A1:A" & a)
    Set bb = Sheet2.Range("A1:A" & b)
    On Error Resume Next
        For Each Cell In bb
            aa.Find(Cell).Offset(, 1) = Cell.Offset(, 1)
        Next
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub

[wildti]

You my friend are a legend! Thank you very much

[holycow]

You're welcome