Excel VBA Macro Match / Compare two sheets and list out distinct values of both in new sheets

Query:

I have data in sheet1 & similar data in sheet2, however, few of rows cell data is changed, I want to bring all extra data from both the sheet to new sheet with row number so that i can check & correct them one by one.

Solution:

I assume that a number of rows are same & each row has index number in acolumn then using below macro you can search for distinct values in both the sheet & bring them to a new sheet. Download sample file from below:

Click to Downlod

Option Explicit

Sub Compare_List_Diff()



Dim arrM, d As Object, rngM As Range

Dim arrT, d2 As Object, rngT As Range

Dim r As Integer

Dim wsM As Worksheet, wsT As Worksheet, wsR As Worksheet



Dim iRW As Integer, iCL As Integer

Dim LastCell As Range, LastCell2 As Range, LastCell3 As Range

Dim wsMlr As Integer, wsMlc As Integer

Dim wsTlr As Integer, wsTlc As Integer



Set d = CreateObject("Scripting.Dictionary")

Set d2 = CreateObject("Scripting.Dictionary")



Set wsM = Worksheets("Sheet1")

Set wsT = Worksheets("Sheet2")

Set wsR = Worksheets("Diff")



With Application

.ScreenUpdating = False

.DisplayAlerts = False

.EnableEvents = False

.AskToUpdateLinks = False

End With



'get last row of Main

wsM.Select

Set LastCell = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

    Cells.Find(What:="*", SearchOrder:=xlByColumns, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsMlr = LastCell.Row

wsMlc = LastCell.Column



wsT.Select

Set LastCell2 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

    Cells.Find(What:="*", SearchOrder:=xlByColumns, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)

wsTlr = LastCell2.Row

wsTlc = LastCell2.Column



wsR.Select

Set LastCell3 = Cells(Cells.Find(What:="*", SearchOrder:=xlRows, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _

    Cells.Find(What:="*", SearchOrder:=xlByColumns, _

    SearchDirection:=xlPrevious, LookIn:=xlValues).Column)



wsR.Range("2:" & LastCell3.Row).Clear

For iRW = 2 To wsTlr

    'trf main sheet row data to arr and store in dict

    Set rngM = wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc))

    arrM = Application.Transpose(rngM)

    'arr = Application.Transpose(wsM.Range(wsM.Cells(iRW, 2), wsM.Cells(iRW, wsMlc)))

  

    For r = 1 To UBound(arrM, 1)

    If arrM(r, 1) <> "" Then

    d(arrM(r, 1)) = 1

    End If

    Next r



    'trf second sheet row data to range and then to array

    wsT.Select

    Set rngT = wsT.Range(wsT.Cells(iRW, 2), wsT.Cells(iRW, wsTlc))

    arrT = Application.Transpose(rngT.Value)  'values from range to array

  

    For r = 1 To UBound(arrT, 1)

    If arrT(r, 1) <> "" Then

    d2(arrT(r, 1)) = 1

    End If

    Next r



    'check values in array agst dict

    'Erase arrN()

    wsR.Cells(iRW, 1).Value = wsT.Cells(iRW, 1).Value

    wsR.Cells(iRW, 2).Value = "Row " & iRW

  

    For r = 1 To UBound(arrT, 1)

        If Not d.exists(arrT(r, 1)) Then

        'arrN(r, 1) = arrV(r, 1)

        ''wsR.Cells(iRW, r + 1).Value = arrT(r, 1)

        wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrT(r, 1)

        End If

    Next r

  

    For r = 1 To UBound(arrM, 1)

        If Not d2.exists(arrM(r, 1)) Then

        'arrN(r, 1) = arrV(r, 1)

        ''wsR.Cells(iRW, r + 1).Value = arrM(r, 1)

        wsR.Cells(iRW, "IV").End(xlToLeft).Offset(0, 1).Value = arrM(r, 1)

        End If

    Next r

  

Next iRW

wsR.Select





With Application

.ScreenUpdating = True

.DisplayAlerts = True

.EnableEvents = True

.AskToUpdateLinks = True

End With



MsgBox "Done"

End Sub

Thanks for reading give feedback and if you want to customise need, post your query on Group www.ExcelVbaLab.Com

Cheers!!