Match 2 Columns and Copy Rows

[aftabn10]

Hi, thanks to one of my colleague he has helped me write a formula that will from Sheet "Find" trawl through the list and find a matching name on the Sheet "Internal" and then paste the matching name along with the data along the next five columns in the Sheet "Sheet4".

This all works fine, but i have ran into an issue where if I have 2 lines of data for 1 matching name in the internal sheet. I was hoping to get some help to amend the code that i have to be able to add more than 1 line. I have attached a sample workbook, so hopefully somebody can help.

The following is the code that was written:

Sub CopyRows()
    Dim i As Long, k As Long, n As Variant, r As Range
    Application.ScreenUpdating = False
    With Sheets("INTERNAL")
        Set r = Range(.Cells(4, 1), .Cells(4, 1).End(xlDown))
    End With
    k = 3
    i = 2
    While Not IsEmpty(Sheets("Find").Cells(i, 1))
        n = Application.Match(Sheets("Find").Cells(i, 1).Value, r, 0)
        If IsNumeric(n) Then
            Sheets("Find").Cells(i, 1).Interior.ColorIndex = 35
            k = k + 1
            r.Rows(n).Resize(, 5).Copy Sheets("Sheet4").Rows(k)
        Else
            Sheets("Find").Cells(i, 1).Interior.ColorIndex = 3
        End If
        i = i + 1
    Wend
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Thanks in advance.

[StephenR]

So you want to copy every row in Internal which has one of the values in the Find sheet?

Here is a different approach:

Sub x()

Dim rData As Range, r As Range

Application.ScreenUpdating = False

For Each r In Sheets("Find").Range("A2", Sheets("Find").Range("A2").End(xlDown))
    With Sheets("Internal")
        .AutoFilterMode = False
        .Range("A3").AutoFilter Field:=1, Criteria1:=r
        With .AutoFilter.Range
            On Error Resume Next
            Set rData = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
            If Not rData Is Nothing Then
                rData.Copy Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp)(2)
                Set rData = Nothing
            End If
        End With
        .AutoFilterMode = False
    End With
Next r

Application.ScreenUpdating = True

End Sub

[aftabn10]

thanks StephenR, that works! Just out of curiosity and for my knowledge, if I was to later on add an extra 2 columns within the Internal Sheet (A and B) and have the agent name in Column C would i just need to amend the following parts of the code?

.Range("A3").AutoFilter Field:=1, Criteria1:=r

change to C3

and

rData.Copy Sheets("Sheet4").Range("A" & Rows.Count).End(xlUp)(2)

change "A" to "C"

would that be correct. Thanks once again for all your help.

[StephenR]

You would change

.Range("A3").AutoFilter Field:=1, Criteria1:=r

to

.Range("A3").AutoFilter Field:=3, Criteria1:=r

Re second line, would you be wanting to copy all the columns across or just C onwards?

[aftabn10]

Stephen, would want to copy all the columns across.. thanks.

[StephenR]

In that case you don't need to change anything else.