CODEWITHSUNDEEP
vbaexcel
HayleyW
HayleyW

Reputation: 13

Macro to compare two worksheets and highlight where a change has occured

I would like to create a macro within a workbook that can be used as a comparison tool.

Historical data will be added to Worksheet 1 'Historical'. Then current data will be added to Worksheet 2 'New'. The data is in exactly the same format.

The macro should look down column G in worksheet 1 (which is a key identifier) and also column O (which shows a status). Then this data should be compared to column G and O in worksheet 2.

If column G is a match but column O has changed then the entire row, from Worksheet 2 'New', should be pasted into Worksheet 3 'Results'.

Example;

Worksheet 1 'Historical' - Column G, 123456789 and Column O, Not Valid

Worksheet 2 'New' - Column G, 123456789 and Column O, Valid

As there is a match in column G but the status has changed, the row from Worksheet 2 will be pasted into the next free row in Worksheet 3 'Results'

Any help would be greatly appreciated. I have played around with adding Vlookup and Countif into the macro without much success.

Upvotes: 0

Views: 29596

Answers (1)

DaveU
DaveU

Reputation: 1082

This may give you an idea, hope it's helpful.

Sub matchMe()
    Dim wS As Worksheet, wT As Worksheet
    Dim r1 As Range, r2 As Range
    Dim cel1 As Range, cel2 As Range

    Set wS = ThisWorkbook.Worksheets("Sheet1")
    Set wT = ThisWorkbook.Worksheets("Sheet2")

    With wS
        Set r1 = .Range("G1", .Cells(.Rows.Count, .Columns("G:G").Column).End(xlUp))
    End With

    With wT
        Set r2 = .Range("G1", .Cells(.Rows.Count, .Columns("G:G").Column).End(xlUp))
    End With

    On Error Resume Next
    For Each cel1 In r1
        With Application
            Set cel2 = .Index(r2, .Match(cel1.Value, r2, 0)) 'find match in sheet2
            If Err = 0 Then
                If cel1.Offset(, 8) <> cel2.Offset(, 8) Then copyRow cel2 'if difference, copy
            End If
            Err.Clear
        End With
    Next cel1
End Sub

Sub copyRow(cel As Range)
    Dim w As Worksheet, r As Range
    Set w = ThisWorkbook.Worksheets("Sheet3")
    Set r = w.Cells(w.Rows.Count, Columns("G:G").Column).End(xlUp).Offset(1) 'next row
    cel.EntireRow.Copy w.Cells(r.Row, 1)
End Sub

Upvotes: 1

Related Questions