VBA Excel Range Comparison Macro

'Use this VBA Excel macro to quickly compare two ranges and highlight differences on a new unsaved workbook.

'To use, open a new workbook and save as macro enabled workbook. Enable macro settings. Get into the code editor with Alt+F11 and go to Tools > References. Make sure Microsoft Scripting Runtime is checked. Under project explorer, go to modules > insert twice: Module1 and Module2. Copy the MODULE1 code below to Module1 and MODULE2 > Module2. Close VB editor and open some file(s) you want to compare. Open macros (alt+f8) and run the Compare2Ranges macro and follow the prompts. First select an entire range with headers as range1. Then select at least one header key cell (or more) like a person's name or account number, or both, for example. Then optionally select any headers for which you want the tool to ignore changes. Now repeat these three steps with range2 and viola!

'MODULE1 - PRIMARY ROUTINE

Option Explicit

Sub Compare2Ranges()

'//DECLARE VARIABLES
Dim dictrng1 As Object, dictrng2 As Object, dictCombinedHdrs_HdrNm_pField As Object, dictCombinedHdrs_pField_HdrNm As Object
Dim dictIgnoreHdr1 As Object, dictIgnoreHdr2 As Object, dictIgnoreHdr As Object, tempDict As Object, dictRecord As Object
Dim rng1 As Range, rng1Keys As Range, rng1Ignore As Range
Dim rng2 As Range, rng2Keys As Range, rng2Ignore As Range
Dim arr As Variant, arr2 As Variant
Dim b As Byte, b2 As Byte, numFields As Byte
Dim i As Long, i2 As Long, askToIgnore As Long
Dim c As Range
Dim key As Variant, pVal As Variant, pVal2 As Variant
Dim pName As String, uniqueKey As String, thisKey As String, hdrOut As String
Dim newBk As Workbook
Dim ws As Worksheet
Dim allBlank As Boolean

'//INITIAL VARIABLES AND SETTINGS
'/INTIALIZE DICTIONARIES
Set dictrng1 = New Scripting.Dictionary
Set dictrng2 = New Scripting.Dictionary
Set dictCombinedHdrs_HdrNm_pField = New Scripting.Dictionary
Set dictCombinedHdrs_pField_HdrNm = New Scripting.Dictionary
Set dictIgnoreHdr1 = New Scripting.Dictionary
Set dictIgnoreHdr2 = New Scripting.Dictionary
Set dictIgnoreHdr = New Scripting.Dictionary

'/GET 2 RANGES, KEY COLS AND IGNORE COLS FROM USER
On Error Resume Next
If ThisWorkbook.Worksheets("Sheet1").Range("L4") = False _
Or ThisWorkbook.Worksheets("Sheet1").Range("L4") = "" Then
    Set rng1 = Application.InputBox(prompt:="Select first range w/ headers", Title:="Set Range 1", Type:=8)
    If rng1 Is Nothing Then GoTo skipdown
    rng1.Parent.Activate
    Set rng1Keys = Application.InputBox(prompt:="Select unique key fields - select header cell(s)", Title:="Set Keys - Range 1", Type:=8)
    If rng1Keys Is Nothing Then GoTo skipdown
    Set rng1Ignore = Application.InputBox(prompt:="Select fields to ignore - select header cell(s) or cancel", Title:="Set Ignores - Range 1", Type:=8)
    Set rng2 = Application.InputBox(prompt:="Select second range w/ headers", Title:="Set Range 2", Type:=8)
    If rng2 Is Nothing Then GoTo skipdown
    rng2.Parent.Activate
    Set rng2Keys = Application.InputBox(prompt:="Select unique key fields - select header cell(s)", Title:="Set Keys - Range 2", Type:=8)
    If rng2Keys Is Nothing Then GoTo skipdown
    Set rng2Ignore = Application.InputBox(prompt:="Select fields to ignore - select headers cell(s) or cancel", Title:="Set Ignores - Range 2", Type:=8)
Else
    'Default ranges
    Set rng1 = ActiveWorkbook.Sheets("Aug").Range("A1:L1525")
    rng1.Parent.Activate
    'Set rng1Keys = ActiveWorkbook.Sheets("Aug").Range("B1,L1")
    Set rng1Keys = ActiveWorkbook.Sheets("Aug").Range("B1,K1")
    'Set rng1Ignore = ActiveWorkbook.Sheets("Aug").Range("E1,J1,K1")
    Set rng1Ignore = ActiveWorkbook.Sheets("Aug").Range("I1,J1")

    Set rng2 = ActiveWorkbook.Sheets("Sep").Range("A1:K1527")
    rng2.Parent.Activate
    Set rng2Keys = ActiveWorkbook.Sheets("Sep").Range("B1,K1")
    Set rng2Ignore = ActiveWorkbook.Sheets("Sep").Range("I1,J1")
End If
On Error GoTo 0

'/ENVIRONMENT SETTINGS
Optimize True

'//MAIN CODE
'/IMPORT RANGES TO ARRAYS - IGNORE EMPTY COLS
arr = rng1
ReDim tempArr(LBound(arr, 1) To UBound(arr, 1), 1 To 1)
b2 = 1
For b = LBound(arr, 2) To UBound(arr, 2)
    If Not IsColumnBlank(arr, b) Then
        ReDim Preserve tempArr(LBound(arr, 1) To UBound(arr, 1), 1 To b2)
        For i = LBound(arr, 1) To UBound(arr, 1)
            tempArr(i, b2) = arr(i, b)
        Next i
        b2 = b2 + 1
    End If
Next b
arr = tempArr
arr2 = rng2
ReDim tempArr(LBound(arr2, 1) To UBound(arr2, 1), 1 To 1)
b2 = 1
For b = LBound(arr2, 2) To UBound(arr2, 2)
    If Not IsColumnBlank(arr2, b) Then
        ReDim Preserve tempArr(LBound(arr2, 1) To UBound(arr2, 1), 1 To b2)
        For i = LBound(arr2, 1) To UBound(arr2, 1)
            tempArr(i, b2) = arr2(i, b)
        Next i
        b2 = b2 + 1
    End If
Next b
arr2 = tempArr
Erase tempArr


'/ADD ARRAYS TO DICTIONARIES
'>Add rng1 and rng2 records to dicts via recordClass class
'>keys=specified cols in rng1&2b, vals=record object

'>Ignorable fields dicts - step 1: add fields specified by user
'>dictIgnoreHdr1=Col_Name|1
If Not rng1Ignore Is Nothing Then
For Each c In rng1Ignore
    If Not dictIgnoreHdr1.Exists(c.value) Then
        dictIgnoreHdr1.Add c.value, 1
    End If
Next c
End If
'>dictIgnoreHdr2=Col_Name|1
If Not rng2Ignore Is Nothing Then
For Each c In rng2Ignore
    If Not dictIgnoreHdr2.Exists(c.value) Then
        dictIgnoreHdr2.Add c.value, 1
    End If
Next c
End If

'>Combined header dict - step 1: gather headers and track whether in just rng1 (1), just rng2 (2) or both (3)
'>dictCombinedHdrs_HdrNm_pField=Col_Name|1, 2 or 3
For b = LBound(arr, 2) To UBound(arr, 2)
    If Not dictCombinedHdrs_HdrNm_pField.Exists(arr(1, b)) Then
        dictCombinedHdrs_HdrNm_pField.Add arr(1, b), 1
    End If
Next b
For b = LBound(arr2, 2) To UBound(arr2, 2)
    If Not dictCombinedHdrs_HdrNm_pField.Exists(arr2(1, b)) Then
        dictCombinedHdrs_HdrNm_pField.Add arr2(1, b), 2
    Else
        dictCombinedHdrs_HdrNm_pField(arr2(1, b)) = 3
    End If
Next b

'>Combined header dict - step 2: if there are any header diffs ask user if they want to ignore and add to ignore dicts
'>then change combined header vals to pField#
'>dictCombinedHdrs_HdrNm_pField=Col_Name|pField#
numFields = dictCombinedHdrs_HdrNm_pField.Count
b = 1
For Each key In dictCombinedHdrs_HdrNm_pField.Keys
    If dictCombinedHdrs_HdrNm_pField(key) = 1 Then
        If Not dictIgnoreHdr1.Exists(key) Then
            askToIgnore = MsgBox(prompt:="Header '" & key & "' found only in first range. Do you want to " _
                & "ignore this column for purposes of identifying differences (choose 'YES' or 'NO'). If 'NO' then every record " _
                & "will be flagged as having a difference and written to final report.", Buttons:=vbYesNo, Title:="Warning")
            If askToIgnore = vbYes Then dictIgnoreHdr1.Add key, 1
        End If
    ElseIf dictCombinedHdrs_HdrNm_pField(key) = 2 Then
        If Not dictIgnoreHdr2.Exists(key) Then
            askToIgnore = MsgBox(prompt:="Header '" & key & "' found only in second range. Do you want to " _
                & "ignore this column for purposes of identifying differences (choose 'YES' or 'NO'). If 'NO' then every record " _
                & "will be flagged as having a difference and written to final report.", Buttons:=vbYesNo, Title:="Warning")
            If askToIgnore = vbYes Then dictIgnoreHdr2.Add key, 1
        End If
    End If
    dictCombinedHdrs_HdrNm_pField(key) = "pField" & b
    b = b + 1
Next key

'>Build inverse combined header dict
'>dictCombinedHdrs_pField_HdrNm=pField#|Col_Name)
For Each key In dictCombinedHdrs_HdrNm_pField.Keys
    dictCombinedHdrs_pField_HdrNm.Add dictCombinedHdrs_HdrNm_pField(key), key
Next key

'>Ignorable fields dicts - step 2: update keys to pField#
'>dictIgnoreHdr#=pField#|1
Set tempDict = dictIgnoreHdr1
Set dictIgnoreHdr1 = New Scripting.Dictionary
For Each key In tempDict
    If Not dictIgnoreHdr1.Exists(dictCombinedHdrs_HdrNm_pField(key)) Then
        dictIgnoreHdr1.Add dictCombinedHdrs_HdrNm_pField(key), 1
    End If
    If Not dictIgnoreHdr.Exists(dictCombinedHdrs_HdrNm_pField(key)) Then
        dictIgnoreHdr.Add dictCombinedHdrs_HdrNm_pField(key), 1
    End If
Next key
Set tempDict = dictIgnoreHdr2
Set dictIgnoreHdr2 = New Scripting.Dictionary
For Each key In tempDict
    If Not dictIgnoreHdr2.Exists(dictCombinedHdrs_HdrNm_pField(key)) Then
        dictIgnoreHdr2.Add dictCombinedHdrs_HdrNm_pField(key), 1
    End If
    If Not dictIgnoreHdr.Exists(dictCombinedHdrs_HdrNm_pField(key)) Then
        dictIgnoreHdr.Add dictCombinedHdrs_HdrNm_pField(key), 1
    End If
Next key
Set tempDict = Nothing

'Fill dictrng1 with records
For i = LBound(arr, 1) + 1 To UBound(arr, 1)
    Set dictRecord = New Scripting.Dictionary
    allBlank = True
    For b = LBound(arr, 2) To UBound(arr, 2)
        pName = dictCombinedHdrs_HdrNm_pField(arr(1, b))
        pVal = CVar(arr(i, b))
        If allBlank = True Then
            If pVal <> "" Then
                allBlank = False
            End If
        End If
        dictRecord.Add pName, pVal
    Next b
    If allBlank = False Then
        uniqueKey = ""
        For Each c In rng1Keys
            If dictRecord.Exists(dictCombinedHdrs_HdrNm_pField(c.value)) Then
                thisKey = dictRecord(dictCombinedHdrs_HdrNm_pField(c.value))
            Else
                MsgBox "error"
            End If
            uniqueKey = uniqueKey & thisKey
        Next c
        uniqueKey = GetUniqueKey(dictrng1, uniqueKey)
        If Not dictrng1.Exists(uniqueKey) Then
            dictrng1.Add uniqueKey, dictRecord
        Else
            MsgBox "Error - duplicate keys"
        End If
    End If
Next i

'Fill dictrng2 with records
For i = LBound(arr2, 1) + 1 To UBound(arr2, 1)
    Set dictRecord = New Scripting.Dictionary
    allBlank = True
    For b = LBound(arr2, 2) To UBound(arr2, 2)
        pName = dictCombinedHdrs_HdrNm_pField(arr2(1, b))
        pVal = CVar(arr2(i, b))
        If allBlank = True Then
            If pVal <> "" Then
                allBlank = False
            End If
        End If
        dictRecord.Add pName, pVal
    Next b
    If allBlank = False Then
        uniqueKey = ""
        For Each c In rng2Keys
            If dictRecord.Exists(dictCombinedHdrs_HdrNm_pField(c.value)) Then
                thisKey = dictRecord(dictCombinedHdrs_HdrNm_pField(c.value))
            Else
                MsgBox "error"
            End If
            uniqueKey = uniqueKey & thisKey
        Next c
        uniqueKey = GetUniqueKey(dictrng2, uniqueKey)
        If Not dictrng2.Exists(uniqueKey) Then
            dictrng2.Add uniqueKey, dictRecord
        Else
            MsgBox "Error - duplicate keys"
        End If
    End If
Next i

'Write record differences to arr1 (vals) and formats to arr2 (0 = reg, 0.1 = reg/comma # format, 1 = Bold, 1.1 = bold/charcoal, 2 = yellow, 2.1 yellow/comma)
ReDim arr(1 To UBound(arr, 1) + UBound(arr2, 1) + 10, 1 To numFields + 2)
arr2 = arr

'>Header
arr(1, 1) = "Rng"
arr2(1, 1) = 1
arr(1, 2) = "Key"
arr2(1, 2) = 1
For b = 1 To numFields
    If dictCombinedHdrs_pField_HdrNm.Exists("pField" & b) Then
        hdrOut = dictCombinedHdrs_pField_HdrNm("pField" & b)
    Else
        hdrOut = "pField" & b
    End If
    arr(1, b + 2) = hdrOut
    If Not dictIgnoreHdr.Exists("pField" & b) Then
        arr2(1, b + 2) = 1
    Else
        arr2(1, b + 2) = 1.1
    End If
Next b

'>Diffs: in rng1 not rng2
i = 1
i2 = 0
For Each key In dictrng1.Keys
    If Not dictrng2.Exists(key) Then
        If i2 = 0 Then
            i = i + 1
            arr(i, 1) = "Records in range1 only"
            arr2(i, 1) = 1
            i = i + 1
            i2 = 1
        End If
        arr(i, 1) = "Rng1"
        arr(i, 2) = "'" & key
        For b = 1 To numFields
            pName = "pField" & b
            If dictrng1(key).Exists(pName) Then
                pVal = dictrng1(key)(pName)
            Else
                pVal = ""
            End If
            arr(i, b + 2) = pVal
        Next b
        i = i + 1
    End If
Next key

'>Diffs: in rng2 not rng1
i2 = 0
For Each key In dictrng2.Keys
    If Not dictrng1.Exists(key) Then
        If i2 = 0 Then
            i = i + 1
            arr(i, 1) = "Records in range2 only"
            arr2(i, 1) = 1
            i = i + 1
            i2 = 1
        End If
        arr(i, 1) = "Rng2"
        arr(i, 2) = "'" & key
        For b = 1 To numFields
            pName = "pField" & b
            If dictrng2(key).Exists(pName) Then
                pVal = dictrng2(key)(pName)
            Else
                pVal = ""
            End If
            arr(i, b + 2) = pVal
        Next b
        i = i + 1
    End If
Next key

'>Changes
i = i + 1
i2 = i
arr(i, 1) = "Changes"
arr2(i, 1) = 1
i = i + 1
For Each key In dictrng1.Keys
    If dictrng2.Exists(key) Then
        If Not IsEqual(dictrng1(key), dictrng2(key), dictIgnoreHdr) Then
            arr(i, 1) = "Rng1"
            arr(i, 2) = "'" & key
            For b = 1 To numFields
                pName = "pField" & b
                pVal = dictrng1(key)(pName)
                arr(i, b + 2) = pVal
            Next b
            i = i + 1
            arr(i, 1) = "Rng2"
            arr(i, 2) = "'" & key
            For b = 1 To numFields
                pName = "pField" & b
                pVal = dictrng2(key)(pName)
                pVal2 = dictrng1(key)(pName)
                arr(i, b + 2) = pVal
                If pVal <> pVal2 And Not dictIgnoreHdr.Exists(pName) Then
                    arr2(i, b + 2) = 2
                End If
            Next b
            i = i + 1
        End If
    End If
Next key
If i2 = i Then arr(i, 1) = "No differences"

'Clear memory
Set dictrng1 = Nothing
Set dictrng2 = Nothing
Set rng1 = Nothing
Set rng2 = Nothing

'Write to sht
Set newBk = Workbooks.Add
Set ws = newBk.Sheets(1)
ws.Cells(1, 1).Resize(UBound(arr, 1), UBound(arr, 2)) = arr
For i = LBound(arr2, 1) To UBound(arr2, 1)
    For b = LBound(arr2, 2) To UBound(arr2, 2)
    If arr2(i, b) = 1 Then
        ws.Cells(i, b).Font.Bold = True
    ElseIf arr2(i, b) = 1.1 Then
        ws.Cells(i, b).Font.Bold = True
        ws.Cells(i, b).Font.Color = RGB(128, 128, 128)
    ElseIf arr2(i, b) = 2 Then
        ws.Cells(i, b).Interior.Color = RGB(255, 255, 0)
    End If
    Next b
Next i

'Touchups
ws.Cells.Columns.AutoFit
ws.Columns(1).ColumnWidth = 10
ws.Columns(2).Delete
FormatCurrencyColumns ws

skipdown:
'ENVIRONMENT SETTINGS
Optimize False

End Sub

'MODULE2 - SECONDARY ROUTINES

Function GetUniqueKey(dict As Dictionary, key As String) As String

Dim newKey As String
Dim suffix As Long

newKey = key
suffix = 1

While dict.Exists(newKey)
    newKey = key & "-" & suffix
    suffix = suffix + 1
Wend

GetUniqueKey = newKey

End Function

'Adjusts Excel settings for faster VBA processing
Public Sub Optimize(ByVal Toggle As Boolean)
    Application.ScreenUpdating = Not Toggle
    Application.EnableEvents = Not Toggle
    Application.DisplayAlerts = Not Toggle
    Application.EnableAnimations = Not Toggle
    Application.DisplayStatusBar = Not Toggle
    Application.PrintCommunication = Not Toggle
    Application.Calculation = IIf(Toggle, xlCalculationManual, xlCalculationAutomatic)
End Sub

Sub DeOptimize()
Optimize False
End Sub

Function IsColumnBlank(arr As Variant, colIndex As Byte) As Boolean
    Dim i As Long
    Dim numRows As Long

    ' Get the number of rows in the array
    numRows = UBound(arr, 1) ' Assuming the array is 2D and the first dimension is rows

    ' Loop through each row in the specified column
    For i = 1 To numRows
        ' Check if the cell is not empty, null, or a blank string
        If Not IsEmpty(arr(i, colIndex)) And Not IsNull(arr(i, colIndex)) And arr(i, colIndex) <> "" Then
            IsColumnBlank = False
            Exit Function
        End If
    Next i

    ' If we loop through all rows without finding non-blank cells, return True
    IsColumnBlank = True
End Function

Function IsEqual(rec1 As Object, rec2 As Object, excludeDict As Object) As Boolean

Dim pVal1 As Variant, pVal2 As Variant
Dim cond1 As Boolean, cond2 As Boolean
Dim i As Byte
Dim key As Variant

IsEqual = False
For Each key In rec1.Keys
    pVal1 = rec1(key)
    pVal2 = rec2(key)
    cond1 = pVal1 = pVal2
    cond2 = excludeDict.Exists(key)
    If Not cond1 And Not cond2 Then Exit Function
Next key
IsEqual = True

End Function
Sub FormatCurrencyColumns(ws As Worksheet)

    Dim colRange As Range
    Dim cell As Range
    Dim decimalCount As Long
    Dim totalNonEmptyCells As Long
    Dim lastRow As Long
    Dim lastCol As Long
    Dim col As Long
    Dim threshold As Double

    ' Get the last used row and column in the active sheet
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    ' Set threshold (e.g., 50%)
    threshold = 0.5

    ' Loop through each column in the used range
    For col = 1 To lastCol
        ' Define the range for the entire used column
        Set colRange = ws.Range(ws.Cells(1, col), ws.Cells(lastRow, col))

        ' Initialize counters
        decimalCount = 0
        totalNonEmptyCells = 0

        ' Iterate through the column
        For Each cell In colRange
            If IsNumeric(cell.value) Then
                totalNonEmptyCells = totalNonEmptyCells + 1
                If InStr(CStr(cell.value), ".") > 0 Then
                    decimalCount = decimalCount + 1
                End If
            End If
        Next cell

        ' Determine if the majority of non-empty cells are numbers with decimals
        If totalNonEmptyCells > 0 And (decimalCount / totalNonEmptyCells) >= threshold Then
            ' Apply comma style to the entire column
            colRange.NumberFormat = "#,##0.00"
        End If
    Next col

    'MsgBox "Currency formatting applied where applicable."
End Sub