Compare two Worksheets and Copy Matches to a Third Worksheet

[NorthbyNorthwest]

Hi, everyone. I’mtrying to automate a project. In past I have been able to compare a columnin Sheet1 to a column in Sheet2 and when a match is found copy the entire rowfrom Sheet2 to another worksheet with a VBA loop. But this was always based there being onematch. What do you do when Sheet2 in some instances will have two or three rowmatches and you want to copy them all to Worksheet3?<o></o>

[FONT=Calibri][SIZE=3][COLOR=#000000]Sub FindMatches()<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim SourceSheet AsString, _<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    CompareSheet AsString, _<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    OutputSheet AsString<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim rngCell AsRange, _<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    SourceRange AsRange, _<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    CompareRange AsRange<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim FormulaStringAs String<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim PasteRow AsLong<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim FinalRow AsLong<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Dim lastColumn AsInteger<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    <o:p></o:p>[/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<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]'which would cause macro code to fail or return a wrongresult<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]With ActiveSheet<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]End With<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]If lastColumn <> 36 Then MsgBox "Table structurehas changed. Column(s) have been added or deleted.", vbOKOnly<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]ActiveSheet.Name = "Sheet1"<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name ="Matches"<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]On Error Resume Next<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]Sheets("Sheet1").Delete<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]'code to create list of matches<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    SourceSheet ="Sheet1"<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    CompareSheet ="Sheet2"<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    OutputSheet ="Matches"<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]    Set SourceRange =Sheets(SourceSheet).Range("D2:D" &Sheets(SourceSheet).Range("D" & Rows.Count).End(xlUp).Row)<o:p></o:p>[/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)<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]   Application.ScreenUpdating = False<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    <o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]    For Each rngCellIn Sheets(SourceSheet).Range(SourceRange.Address)<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]        IfInStr(CompareSheet, " ") = 0 Then<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           FormulaString = strSourceSheet & "!" & rngCell.Address& "," & CompareSheet & "!" &CompareRange.Address & ",1,FALSE"<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        Else<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           FormulaString = "'" & SourceSheet & "'!"& rngCell.Address & ",'" & CompareSheet &"'!" & CompareRange.Address & ",1,FALSE"<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        End If<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]'If there's no error (i.e. a match) for the current cellvalue, then...<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        IfIsError(Evaluate("VLOOKUP(" & strFormulaString &")")) = False Then<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]             '...copythe record to the next available row in Col A of the 'OutputSheet' tab.<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            PasteRow =Sheets(OutputSheet).Cells(Rows.Count, "A").End(xlUp).Row + 1<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            Sheets(CompareSheet).Range("A"& rngCell.Row & ":AJ" & rngCell.Row).Copy _<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]            Sheets(OutputSheet).Range("A"& PasteRow)<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]           Application.CutCopyMode = False<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]        End If<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]    Next rngCell<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]'copy header row from Detail sheet to Matches sheet<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]   Sheets("Sheet2").Range("A1").EntireRow.CopyDestination:= _<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]   Sheets("Matches").Range("A1")<o:p></o:p>[/COLOR][/SIZE][/FONT]
<o:p></o:p>
[FONT=Calibri][SIZE=3][COLOR=#000000]'do some formatting<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Cells.Select<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]   Selection.RowHeight = 13<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]    Application.ScreenUpdating= True<o:p></o:p>[/COLOR][/SIZE][/FONT]
[FONT=Calibri][SIZE=3][COLOR=#000000]End Sub<o:p></o:p>[/COLOR][/SIZE][/FONT]

 

[dmt32]

Hi,
there are few ways to do what you want - here is one using Union Method

Place ALL codes in STANDARD module.

Sub FindMatches()
    Dim SourceSheet As Worksheet, CompareSheet As Worksheet
    Dim OutputSheet As Worksheet
    Dim SourceDataRange As Range, CompareDataRange As Range
    Dim SourceCell As Range




   On Error Resume Next
'set object variables
    With ThisWorkbook
        Set SourceSheet = .Worksheets("Sheet1")
        Set CompareSheet = .Worksheets("Sheet2")
'check of sheet exists
        If IsError(.Worksheets("Matches")) Then .Worksheets.Add.Name = "Matches"
        Set OutputSheet = .Worksheets("Matches")
    End With
    
   On Error GoTo exitsub
   
'Check to see if table structure has been changed since lasttime,
'specifically if columns have been added or deleted
'which would cause macro code to fail or return a wrongresult


   If IsNotValidTableStructure(SourceSheet) Then Exit Sub
   
    
'source sheet data range
    With SourceSheet
        Set SourceDataRange = .Range(.Range("D2"), .Range("D" & .Rows.Count).End(xlUp))
    End With
'compare sheet data range
    With CompareSheet
        Set CompareDataRange = .Range(.Range("A11"), .Range("A" & .Rows.Count).End(xlUp))
    End With
    
'clear any old output sheet data
    OutputSheet.UsedRange.ClearContents
    
    SourceDataRange.EntireRow.Hidden = False
    
    For Each SourceCell In SourceDataRange.Cells
'code to create list of matches
        CopyMatches SourceCell.Text, CompareDataRange, OutputSheet
    Next SourceCell
    
exitsub:
'report errors
    If Err > 0 Then MsgBox (Error(Err)), 48, "Error"
End Sub


Sub CopyMatches(ByVal Text As String, ByVal CompareRange As Range, ByVal OutputSheet As Object)
    Dim CopyRange As Range, c As Range
    Dim DestRange As Range
    
    For Each c In CompareRange.Cells
        If c.Value = Text Then
            If CopyRange Is Nothing Then
                Set CopyRange = c
            Else
                Set CopyRange = Union(CopyRange, c)
            End If
        End If
    Next c
    If Not CopyRange Is Nothing Then
'copy all matches to output sheet in one go
        Set DestRange = OutputSheet.Cells(OutputSheet.Cells(OutputSheet.Rows.Count, "A").End(xlUp).Row + 1, 1)
        CopyRange.EntireRow.Copy DestRange
    End If
'clear objects
        Set CopyRange = Nothing
        Set DestRange = Nothing
End Sub


Function IsNotValidTableStructure(ByVal sh As Object) As Boolean
    Dim Response As VbMsgBoxResult
    Dim LastColumn As Long


    LastColumn = sh.Cells(1, sh.Columns.Count).End(xlToLeft).Column
    If LastColumn <> 36 Then
    
    Response = MsgBox("Table structure has changed. Column(s) have been added or deleted." & _
                        Chr(10) & Chr(10) & "Do You Want To Continue?", 36, "Table Structure")
    End If
    
    IsNotValidTableStructure = CBool(Response = vbNo)
End Function

I broke the code down into 3 parts which hopefully, will make it easier for you to read & update if required.

Solution not fully tested so as always MAKE A BACKUP before testing new code.

Others here may have alternative solutions.


Dave

 

[NorthbyNorthwest]

Thanks, bunches, Dave. I wish I could express how much I appreciate your taking the time to respond to my question. The Union method is not something I'm familiar with. There's so much to learn about VBA. As I've said before, all of you who volunteer to help struggling newbies like me wrap our heads around code are awesome!