Below is the code I have to compare the row values of the columns that have the same header 'abc', 'def', and 'ghi' in ws_checks, assuming those columns are in both Sheet1 and Sheet2. How can it be expanded to compare multiple columns (not just 2, can be any number of columns in 1 sheet or across all Sheets 1 to 5) that share the same column header?
'''
Dim r, lr, lr1, lr2, col1, col2, lc_checks, nextCol As Long
Dim Rng1, Rng2, Found1, Found2 As Range
Dim foundX As Boolean
Dim header, headerList As Variant
' List of column headers to compare
headerList = Array("abc", "def", "ghi")
' Loop through each header in the list
For Each header In headerList
' Find the column index of the header in both sheets
On Error Resume Next ' Handle the case where header might not be found
col1 = Application.Match(header, ws1.Rows(2), 0)
col2 = Application.Match(header, ws2.Rows(2), 0)
On Error GoTo 0
' Find the last row with data in the columns
lr1 = ws1.Cells(ws1.Rows.Count, col1).End(xlUp).Row
lr2 = ws2.Cells(ws2.Rows.Count, col2).End(xlUp).Row
' Find the next column to paste the next check
lc_checks = ws_checks.Cells(1, Columns.Count).End(xlToLeft).Column
nextCol = lc_checks + 1
' Compare values in the rows of the current column header
For r = 3 To Application.WorksheetFunction.Min(lr1, lr2)
ws_checks.Cells(1, nextCol).Value = ws1.Cells(2, col1).Value
If ws1.Cells(r, col1).Value = ws2.Cells(r, col2).Value Then
ws_checks.Cells(r - 1, nextCol).Value = "Match"
Else: ws_checks.Cells(r - 1, nextCol).Value = "Mismatch"
Next r
'''
Try this out. Comments in code.
Option Explicit
Const HEADER_ROW As Long = 2 'header row# on all sheets
Sub CompareColumns()
Dim cols As Collection, headerList, header, n As Long, i As Long, j As Long
Dim rng As Range, v, v2, wb As Workbook, wsCheck As Worksheet
Dim cPos As Long, ok As Boolean, colOK As Boolean, clr As Long, flag As String
headerList = Array("abc", "def", "ghi") 'column headers to compare
Set wb = ThisWorkbook
Set wsCheck = ThisWorkbook.Worksheets("ws_checks")
wsCheck.Cells.Clear
For Each header In headerList 'check each header
Debug.Print "---Checking:" & header & "---"
Set cols = CompareRanges(wb, header) 'check all sheets for the header
If cols.Count > 1 Then 'any sheets to compare?
colOK = True 'reset flag
cPos = HeaderPos(wsCheck, header) 'header position on "check "sheet
ResetFill cols 'clear previous flags
For i = 1 To cols(1).Cells.Count 'column length
flag = "" 'reset flag
v = cols(1)(i) 'read value from first column
For j = 2 To cols.Count 'check other columns
v2 = cols(j).Cells(i).Value
If Len(v) = 0 Or Len(v2) = 0 Then 'either value is blank?
clr = RGB(200, 200, 200)
flag = "---"
Else
If v2 <> v Then 'mismatch?
clr = vbRed
flag = "X"
End If
End If
If Len(flag) > 0 Then
For Each rng In cols 'flag all columns at this position
rng.Cells(i).Interior.Color = clr
Next rng
colOK = False 'column not matched
Exit For 'done checking
End If
Next j 'next comparison column
'flag the cell on ws_checks
wsCheck.Cells(cols(1)(i).Row, cPos).Value = IIf(Len(flag) = 0, "O", flag)
Next i
wsCheck.Cells(HEADER_ROW, cPos).Interior.Color = IIf(colOK, vbGreen, vbRed)
End If
Next header
End Sub
'Check all sheets in workbook `wb` for the header `hdr` on the configured row
' Return a collection of all data columns below found headers, sized to the max length
' of all of the returned ranges
Function CompareRanges(wb As Workbook, hdr) As Collection
Dim ws As Worksheet, col As New Collection, maxRow As Long, lr As Long
Dim rng As Range, m, i As Long, c As Range, lc As Long
For Each ws In wb.Worksheets
lc = ws.Cells(HEADER_ROW, ws.Columns.Count).End(xlToLeft).Column
For Each c In ws.Cells(HEADER_ROW, 1).Resize(1, lc).Cells
If c.Value = hdr Then
col.Add ws.Cells(HEADER_ROW + 1, c.Column)
lr = ws.Cells(Rows.Count, c.Column).End(xlUp).Row
If lr > maxRow Then maxRow = lr
End If
Next c
Next ws
Set CompareRanges = New Collection
If col.Count = 0 Then Exit Function
For Each rng In col 'make all columns same size as the longest one
CompareRanges.Add rng.Resize(maxRow - HEADER_ROW)
Next rng
End Function
'Clear any fill from a collection of ranges
Sub ResetFill(col As Collection)
Dim rng As Range
For Each rng In col
Debug.Print rng.Parent.Name, rng.Address
rng.Interior.ColorIndex = xlNone
Next rng
End Sub
'Return the column number for header `hdr` on sheet `ws`
' Add the header if not found
Function HeaderPos(ws As Worksheet, hdr) As Long
Dim m
m = Application.Match(hdr, ws.Rows(HEADER_ROW), 0)
If IsError(m) Then
m = ws.Cells(HEADER_ROW, Columns.Count).End(xlToLeft).Column
If Len(ws.Cells(HEADER_ROW, m)) > 0 Then m = m + 1
ws.Cells(HEADER_ROW, m).Value = hdr
End If
HeaderPos = CLng(m)
End Function