Need to match items on two different lists, then copy and paste matches
Posted by Claudette on May 09, 2001 9:54 AM
Hi! I need help. I have two lists. Each list has two columns(one for part numbers, one for weight), for a total of four columns.
If a part number in the first list matches a part number in the second list, I need BOTH the part number and it's corresponding weight from BOTH lists to be copied into another sheet, adjacent to each other.
How can I do this? Should I use a macro? How can I get it to copy the part number and the weight in the adjacent column into a new sheet AND get it to copy the same items in the second list ADJACENT to the first info set? I am pretty good at conditionals and programming, so I don't need basic instruction, I just have no idea of the syntax or key words or format to program the macro? I would appreciate anyyy help at all!!
Thanks so much everyone!
Posted by Dave Hawley on May 09, 2001 10:44 AM
Hi Claudette
Move you four Columns to Columns A:D then insert a Sheet and call it "Copy" now run the macro below from the sheet with the lists on.
Sub CopyDupes()
'Written by Ozgrid Business Applications
'www.ozgrid.com
Dim rList1 As Range
Dim rList2 As Range
Dim rCell As Range
Application.ScreenUpdating = False
Set rList1 = Range("A2", Range("A65536").End(xlUp))
Set rList2 = Range("C2", Range("C65536").End(xlUp))
For Each rCell In rList1
With WorksheetFunction
If .CountIf(rList2, rCell) <> 0 And _
.CountIf(Sheets("Copy").Columns(1), rCell) = 0 Then
rCell.Range("A1:D1").Copy _
destination:=Sheets("Copy").Range("A65536").End(xlUp).Offset(1, 0)
End If
End With
Next rCell
Set rList1 = Nothing
Set rList2 = Nothing
Application.ScreenUpdating = True
End Sub
If your list is very long there are other methods other than a horrible Loop.
Dave
OzGrid Business Applications
Posted by Claudette on May 09, 2001 1:36 PM
I'm ever appreciative!! Thanks so much!
My only question is that looking at the code, it seems like it will only look for matching column A and C cells in the same row.
In Sheet1, I need to be able to grab the contents of cell A2, etc and see if anything from ranges C2:C3000 matches. So lets say C44 matches, then I need to copy A2,B2 to columns A & B of the next empty row in Sheet2. and I need to copy C44 and D44 to the C & D columns next to the matching entry in Sheet2.
What I have is a huge listX of part numbers with the weight in columns A and B. Then I have a huge listY of part numbers and weghts in columns C and D. Not all the entries in X or Y necessarily have a match in the other list, so sorting them doesn't place matching part numbers next to each other.
I have been manually searching with my eyes and they are about to fall off!
Posted by Dave Hawley on May 09, 2001 1:58 PM
Hmmm, Ok let's see if I have understood you. Try this one instead on a copy of your lists.
Sub CopyDupes()
'Written by Ozgrid Business Applications
'www.ozgrid.com
Dim rList1 As Range
Dim rList2 As Range
Dim rCell As Range
Application.ScreenUpdating = False
Set rList1 = Range("A2", Range("A65536").End(xlUp))
Set rList2 = Range("C2", Range("C65536").End(xlUp))
For Each rCell In rList1
With WorksheetFunction
If .CountIf(rList2, rCell) <> 0 And _
.CountIf(Sheets("Copy").Columns(1), rCell) = 0 Then
rCell.Range("A1:B1").Copy _
Destination:=Sheets("Copy").Range("A65536").End(xlUp).Offset(1, 0)
rList2.Find _
(What:=rCell, after:=rList2.Cells(1, 1)).Range("A1:B1").Copy _
Destination:=Sheets("Copy").Range("C65536").End(xlUp).Offset(1, 0)
End If
End With
Next rCell
Set rList1 = Nothing
Set rList2 = Nothing
Application.ScreenUpdating = True
End Sub
Dave
OzGrid Business Applications
Posted by Dave Hawley on May 09, 2001 2:01 PM
Ignore that one. Try this instead
Sub CopyDupes()
'Written by Ozgrid Business Applications
'www.ozgrid.com
Dim rList1 As Range
Dim rList2 As Range
Dim rCell As Range
Application.ScreenUpdating = False
Set rList1 = Range("A2", Range("A65536").End(xlUp))
Set rList2 = Range("C2", Range("C65536").End(xlUp))
For Each rCell In rList1
With WorksheetFunction
If .CountIf(rList2, rCell) <> 0 And _
.CountIf(Sheets("Copy").Columns(1), rCell) = 0 Then
rCell.Range("A1:B1").Copy _
Destination:=Sheets("Copy").Range("A65536").End(xlUp).Offset(1, 0)
rList2.Find _
(What:=rCell, after:=rList2.Cells(1, 1), _
LookAt:=xlWhole, MatchCase:=True).Range("A1:B1").Copy _
Destination:=Sheets("Copy").Range("C65536").End(xlUp).Offset(1, 0)
End If
End With
Next rCell
Set rList1 = Nothing
Set rList2 = Nothing
Application.ScreenUpdating = True
End Sub
OzGrid Business Applications
