Compare Two Worksheets and Copy single Match or Multiple Matches to Another Worksheet

[NorthbyNorthwest]

Hi, all. I’mtrying to automate a project. In past Ihave been able to compare a column in Sheet1 to a column in Sheet2 and when amatch is found copy the entire row from Sheet2 to another worksheet with a VBAloop. But this was always based therebeing one match. In the code example of coding I've been used in past I’m using a VLOOKUP, which once it finds a match is done. What do you do when Sheet2 in some instances will have two or three rowmatches and you want to copy them all to Worksheet3? How can I get VBA to find all matches inSheet2 based on column A values in Sheet1?

[FONT=Calibri][SIZE=3][COLOR=#000000]Sub FindMatch()[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim SourceSheet AsString, _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    CompareSheet AsString, _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    OutputSheet AsString[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim rngCell AsRange, _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    SourceRange AsRange, _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    CompareRange AsRange[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim FormulaStringAs String[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim PasteRow AsLong[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim FinalRow AsLong[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim lastColumn AsInteger[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'Check to see if table structure has been changed since lasttime, specifically if columns have been added or deleted[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]'which would cause macro code to fail or return a wrongresult[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]With ActiveSheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]End With[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]If lastColumn <> 36 Then MsgBox "Table structurehas changed. Column(s) have been added or deleted.", vbOKOnly[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]ActiveSheet.Name = "Sheet1"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name ="Matches"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]On Error Resume Next[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]Sheets("Sheet1").Delete[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'code to create list of matches[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    SourceSheet ="Sheet1"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    CompareSheet ="Sheet2"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    OutputSheet ="Matches"[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Set SourceRange =Sheets(SourceSheet).Range("D2:D" &Sheets(SourceSheet).Range("D" & Rows.Count).End(xlUp).Row)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set CompareRange =Sheets(CompareSheet).Range("A11:A" & Sheets(CompareSheet).Range("A"& Rows.Count).End(xlUp).Row)[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]   Application.ScreenUpdating = False[/COLOR][/SIZE][/FONT]


[FONT=Calibri][SIZE=3][COLOR=#000000]    For Each rngCellIn Sheets(SourceSheet).Range(SourceRange.Address)[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]        IfInStr(CompareSheet, " ") = 0 Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           FormulaString = strSourceSheet & "!" & rngCell.Address& "," & CompareSheet & "!" &CompareRange.Address & ",1,FALSE"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Else[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           FormulaString = "'" & SourceSheet & "'!"& rngCell.Address & ",'" & CompareSheet &"'!" & CompareRange.Address & ",1,FALSE"[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        End If[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'If there's no error (i.e. a match) for the current cellvalue, then...[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        IfIsError(Evaluate("VLOOKUP(" & strFormulaString &")")) = False Then[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]             '...copythe record to the next available row in Col A of the 'OutputSheet' tab.[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            PasteRow =Sheets(OutputSheet).Cells(Rows.Count, "A").End(xlUp).Row + 1[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           Sheets(CompareSheet).Range("A" & rngCell.Row &":AJ" & rngCell.Row).Copy _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            Sheets(OutputSheet).Range("A"& PasteRow)[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           Application.CutCopyMode = False[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        End If[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]    Next rngCell[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'copy header row from Detail sheet to Matches sheet[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]   Sheets("Sheet2").Range("A1").EntireRow.CopyDestination:= _[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]   Sheets("Matches").Range("A1")[/COLOR][/SIZE][/FONT]

[FONT=Calibri][SIZE=3][COLOR=#000000]'do some formatting[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Cells.Select[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]   Selection.RowHeight = 13[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Application.ScreenUpdating= True[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]End Sub[/COLOR][/SIZE][/FONT]

 

[NoSparks]

use the Range.Find Method and the Range.FindNext method
something along the lines of

    For Each rngCell In SourceRange
        Set fndRng = CompareRange.Find(What:=rngCell.Value, LookIn:=xlValues, _
                           LookAt:=xlPart, SearchOrder:=xlByRows, _
                           SearchDirection:=xlNext, MatchCase:=False)
        If Not fndRng Is Nothing Then
            firstAddress = fndRng.Address
            Do
                ' use fndRng.Row for the row number and
                ' whatever it is you want done goes here
                '
                
                'check for more matches and do it again
                Set fndRng = CompareRange.FindNext(fndRng)
            Loop While Not fndRng Is Nothing And fndRng.Address <> firstAddress
        End If
    Next rngCell

 

[Fluff]

Duplicated https://www.mrexcel.com/forum/excel...copy-matches-third-worksheet.html#post5005878


Please do not post the same question multiple times. All clarifications, follow-ups, and bumps should be posted back to the original thread. Per forum rules, posts of a duplicate nature will be locked or deleted (rule 12 here: Forum Rules).

If you do not receive a response, you can "bump" it by replying to it again, though we advise you to wait 24 hours before doing and not to bump a thread more than once a day.

Note that sometimes posts from new users require Moderator approval before you can see them on the public forums. When this happens, you should see a message to that effect when you try to post it. Please be patient and do not attempt to post the question again.