Compare between three columns and highlight common cells across multiple spreadsheets (more than 100 spread sheets)

Question

I'm not that great of a coder so I'd appreciate if people could provide some insight. I want to highlight common cells that are present in three columns across multiple spreadsheets (More than 100 spreadsheets). I tried using ChatGPT code but its causing excel to not respond. An example of what I want is given below along with the ChatGPT code that I tried using. I want to compare and highlight the text with other spreadsheets with sheet 1 while also highlighting the same text that is present in sheet 1.

For example:

And after the code runs

Here's the original code block that I retrieved from ChatGPT. I'm not very good at coding so I need some help with it.

Sub HighlightCommonCells()
    Dim ws As Worksheet
    Dim compareSheet As Worksheet
    Dim cell As Range
    Dim compareRange As Range

    ' Set the sheet to compare against (Sheet1 in this case)
    Set compareSheet = ThisWorkbook.Sheets("Sheet1")

    ' Set the range to compare in the compare sheet (adjust as needed)
    Set compareRange = compareSheet.Range("A:C")

    ' Loop through each sheet
    For Each ws In ThisWorkbook.Sheets
        ' Skip the compare sheet itself
        If ws.Name <> compareSheet.Name Then
            ' Loop through each cell in the specified columns (A, B, C)
            For Each cell In ws.Range("A:C")
                ' Check if the value exists in the compare sheet
                If Application.WorksheetFunction.CountIf(compareRange, cell.Value) > 0 Then
                    ' Highlight the cell
                    cell.Interior.Color = RGB(255, 0, 0) ' Adjust the color as needed
                End If
            Next cell
        End If
    Next ws
End Sub```

Answer 1

Firstly, I would like to state that using ChatGPT is not a favorable circumstance to be invoked here. Proving that you made some researches on your own would be much appreciated, instead...

The artificial intelligence was obviously wrong. You cannot do what you need before checking all unique occurrences in all worksheets.

Take care to have consistent data in all involved sheets. I mean, the next adapted code assumes that all sheets have a header on the first row and the processed part follows starting from the second one.

Please, copy the next adapted version, using a ScriptingDictionary, some arrays and a Union range to do the correct processing (in a fast manner):

Sub CompareThreeCols()
  Dim wb As Workbook, ws As Worksheet, lastR As Long, arrComp, arr, arrFin, rngUn As Range
  Dim compareSheet As Worksheet, i As Long, mtch, k As Long dictComp As Object
  
  Set wb = ActiveWorkbook
  Set compareSheet = wb.Worksheets("Sheet1") 'compare sheeet
  
  lastR = compareSheet.Range("A" & compareSheet.rows.count).End(xlUp).Row 'last row of the sheet in column A:A
  
  arrComp = compareSheet.Range("A2:C" & lastR).Value2
  Set dictComp = CreateObject("Scripting.Dictionary") 'set the necessary dictionary
  For i = 1 To UBound(arrComp) 'extract unique three columns values combination:
    'A:A value is separated by the rest of the concatencated string, to be used in highlighting its occurrences:
    Set dictComp(arrComp(i, 1) & "|" & arrComp(i, 2) & arrComp(i, 3)) = compareSheet.Range("A" & i + 1)
  Next i
  arrComp = dictComp.keys       'place the unique dictionary keys in an array
  ReDim arrFin(UBound(arrComp)) 'redim the final array to have the same number of elements
  
  'extract the common three columns values and place them in an array:
  For Each ws In wb.Worksheets     'iterate between all workbook sheets:
    If Not ws Is compareSheet Then 'exclude the comparizon (first) sheet:
        lastR = ws.Range("A" & ws.rows.count).End(xlUp).Row 'last row of the sheet in column A:A
        arr = ws.Range("A2:C" & lastR).Value2 'place the range in an array for faster processing
        For i = 1 To UBound(arr)              'iterate between the array ROWS:
            mtch = Application.match(arr(i, 1) & "|" & arr(i, 2) & arr(i, 3), arrComp, 0) 'check if it exists in the array
            If Not IsError(mtch) Then 'if it exists:
                arrFin(k) = arr(i, 1) & "|" & arr(i, 2) & arr(i, 3): k = k + 1 'place it in the (temporary) final array
            End If
        Next i
        ReDim Preserve arrFin(k - 1) 'redim the array to keep only filled elements
        arrComp = arrFin             'update arrComp with the matching elements
        
        If Not ws.index = wb.Sheets.count Then 'for the last sheet arrFin is not errased!
            Erase arrFin: ReDim arrFin(k - 1): k = 0 'erase the array content to be used for future matches
        End If
        
    End If
  Next
  
   'create the Union ranges (to highlight all at once) and highlight them:
   Dim El
   For Each ws In wb.Worksheets 'now it includes the compare sheet
        lastR = ws.Range("A" & ws.rows.count).End(xlUp).Row
        arr = ws.Range("A2:C" & lastR).Value2
        For i = 1 To UBound(arr)  'iterate between each array rows
            For Each El In arrFin 'iterate between the final array elements:
                'place in the Union range the A:A matching element, to be highlighted
                If arr(i, 1) = Split(El, "|")(0) Then addToRange rngUn, ws.Range("A" & i + 1)
                If arr(i, 1) & "|" & arr(i, 2) & arr(i, 3) = El Then 'if a match for all three columns value exists:
                    addToRange rngUn, ws.Range("A" & i + 1).Resize(, 3) 'place the three columns range in the Union range
                End If
            Next El
        Next i

        rngUn.Interior.Color = xlRed 'highlight the Union range
        Set rngUn = Nothing          'make it nothing to be used to the next sheet
   Next
End Sub

Sub addToRange(rngU As Range, rng As Range)
    If rngU Is Nothing Then
        Set rngU = rng
    Else
        Set rngU = Union(rngU, rng)
    End If
End Sub

I tried commenting all row which could not be understood as needed.

If there still are aspects not clear enough, do not hesitate to ask for clarifications.