PDA

View Full Version : Match and copy.



wildti
08-18-2014, 03:22 AM
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
08-18-2014, 05:00 AM
Which list would be longer, Sheet1 ColumnA or Sheet2 ColumnA? Would either list contain duplicate entries?

wildti
08-18-2014, 05:16 AM
Hi Thanks the list in Sheet2 is longer. there will me no duplicate entries.
Many Thanks :)

holycow
08-18-2014, 05:32 AM
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
08-18-2014, 02:53 PM
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
08-19-2014, 01:41 AM
You my friend are a legend! Thank you very much :beerchug:

holycow
08-19-2014, 01:57 AM
You're welcome