Hi All,

I would really appreciate some help with the following:

1. I have a workbook with two worksheets.
2. The first worksheet is called "Customer Complaints" and the second
is called "Shipped".
3. I need code that will compare the values in column i on the
"Complaints" worksheet against column D on the "Shipped" worksheet.
4. If matched records are found, a new worksheet should be created
called "Matched".
5. The contents of the entire row of the matched records on the
"Shipped" worksheet should them be copied from the "Shipped" worksheet
and pasted into the "Matched" worksheet.
6. If no matches are found, the code should not copy any values or
create a new worksheet.
7. Please note that there may be multiple rows that match the criteria
in which case I will need the macro to copy all these lines and not
only the first row that matched the criteria.
8. The size of the data on both of the "Customer Complaints" worksheet
and the "Shipped" worksheets will change every day so the code should
be able to adapt accordingly.

I am using Excel 2002 on windows XP.

Any assistance with the above would be greatly appreciated.

Thanks,

Steve

Try the following.

Hth,
Merjet


Sub CopyStuff()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iEnd As Long
Dim iRow As Long
Dim rng1 As Range
Dim rng2 As Range

Set ws1 = Worksheets("Customer Complaints")
Set ws2 = Worksheets("Shipped")
iEnd = ws1.Range("I65536").End(xlUp).Row
Set rng1 = ws1.Range("I1:I" & iEnd)
iEnd = ws2.Range("D65536").End(xlUp).Row
Set rng2 = ws2.Range("D1:D" & iEnd)
For Each c2 In rng2
For Each c1 In rng1
If c1 = c2 Then
iRow = iRow + 1
If iRow = 1 Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Matched"
End If
c2.EntireRow.Copy _
Destination:=ActiveSheet.Range("A" & iRow)
Exit For
End If
Next c1
Next c2
End Sub

And if Merjet's code does not do what you want, try this one. Worksheets(1)
is "Customer Complaints" and Worksheets(2) is "Shipped"

Function SheetExists(SName As String, _
Optional ByVal wb As Workbook) As Boolean
On Error Resume Next
If wb Is Nothing Then Set wb = ThisWorkbook
SheetExists = CBool(Len(wb.Sheets(SName).Name))
End Function


Sub Mtch()
Worksheets(1).Activate
Dim CompRng, ShpdRng As Range
LstRw = Worksheets(1).Cells(Rows.Count, 9).End(xlUp).Row
Set CompRng = Worksheets(1).Range(Cells(1, 9), _
Cells(LstRw, 9))
Set ShpdRng = Worksheets(2).Range("D:D")
For Each c In CompRng
If Not c Is Nothing Then
For Each s In ShpdRng
If s = c Then
If Not SheetExists("Matched") Then
Set NewSheet = Worksheets. _
Add(After:=Sheets(Sheets.Count), _
Type:=xlWorksheet)
NewSheet.Name = "Matched"
End If
Worksheets(2).Activate
shRng = s.Address
Range(shRng).EntireRow.Copy
Worksheets(4).Activate
If Range("$A$1") = "" Then
ActiveSheet.Paste
Else
Range("$A$1").Activate
Do Until ActiveCell = ""
ActiveCell.Offset(1, 0).Activate
Loop
ActiveSheet.Paste
End If
Worksheets(1).Activate
End If
Next s
End If
Next c
Application.CutCopyMode = False
End Sub


"merjet" wrote:

Try the following.

Hth,
Merjet


Sub CopyStuff()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim iEnd As Long
Dim iRow As Long
Dim rng1 As Range
Dim rng2 As Range

Set ws1 = Worksheets("Customer Complaints")
Set ws2 = Worksheets("Shipped")
iEnd = ws1.Range("I65536").End(xlUp).Row
Set rng1 = ws1.Range("I1:I" & iEnd)
iEnd = ws2.Range("D65536").End(xlUp).Row
Set rng2 = ws2.Range("D1:D" & iEnd)
For Each c2 In rng2
For Each c1 In rng1
If c1 = c2 Then
iRow = iRow + 1
If iRow = 1 Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Name = "Matched"
End If
c2.EntireRow.Copy _
Destination:=ActiveSheet.Range("A" & iRow)
Exit For
End If
Next c1
Next c2
End Sub

Thank you both for taking the time to help me.
The code works perfectly!

Cheers,

Steve