Comparing workbooks and deleting duplicates

[k_babb]

Can someone help me with a macro to compare 2 work books both have the same information but work book 2 has new entries i would like a macro to compare each row in workbook 1 with workbook 2 and delete the row in workbook 2 if it exists in workbook 1 so that workbook 2 has only the new information

 

[tigeravatar]

k_babb,

Open the workbook containing old items (workbook 1). Run the following macro. When it asks to open a file, select the workbook containing new items (workbook 2). the macro will delete all duplicate rows found in workbook 2:

Sub tgr()
    
    Static wb2Path As String: wb2Path = Application.GetOpenFilename("Excel Files, *.xls*")
    If wb2Path = "False" Then Exit Sub
    
    Static wb1 As Workbook: Set wb1 = ActiveWorkbook
    Static wb2 As Workbook: Set wb2 = Workbooks.Open(wb2Path)
    
    Static rng1 As Range: Set rng1 = wb1.Sheets(1).UsedRange
    Static rng2 As Range: Set rng2 = wb2.Sheets(1).UsedRange
    
    Dim nRow1 As Long, nCol1 As Long
    Dim nRow2 As Long, nCol2 As Long
    Dim str1Row As String, str2Row As String
    Dim DelRows As Range
    
    For nRow2 = rng2.Row To rng2.Row + rng2.Rows.Count - 1
        str2Row = vbNullString
        For nCol2 = rng2.Column To rng2.Column + rng2.Columns.Count - 1
            str2Row = str2Row & wb2.Sheets(1).Cells(nRow2, nCol2).Text
        Next nCol2
        For nRow1 = rng1.Row To rng1.Row + rng1.Rows.Count - 1
            str1Row = vbNullString
            For nCol1 = rng1.Column To rng1.Column + rng1.Columns.Count - 1
                str1Row = str1Row & wb1.Sheets(1).Cells(nRow1, nCol1).Text
            Next nCol1
            If str2Row = str1Row Then
                If DelRows Is Nothing Then
                    Set DelRows = wb2.Sheets(1).Rows(nRow2)
                Else
                    Set DelRows = Union(DelRows, wb2.Sheets(1).Rows(nRow2))
                End If
                Exit For
            End If
        Next nRow1
    Next nRow2
    
    If Not DelRows Is Nothing Then DelRows.Delete xlShiftUp
    
End Sub

Hope that helps,
~tigeravatar

 

[k_babb]

that's fantasic thank you so much

is there anyway to stop the macro when it reaches row 1 as this row contains the header information which if possible i would like to keep

thanks again

 

[tigeravatar]

Change lines like this one:

For nRow2 = rng2.Row To rng2.Row + rng2.Rows.Count - 1

To be like this instead:

For nRow2 = rng2.Row + 1 To rng2.Row + rng2.Rows.Count - 1

 

[k_babb]

Thanks Working great this will save me hours of work thanks again