如何比较不同工作表中具有相同标题的多列的行值，即使这些列仅位于同一个工作表中？

Question

下面是我必须比较 ws_checks 中具有相同标题“abc”、“def”和“ghi”的列的行值的代码，假设这些列同时位于 Sheet1 和 Sheet2 中。如何扩展以比较共享相同列标题的多列（不仅仅是 2 列，可以是 1 个工作表中或所有工作表 1 到 5 中的任意数量的列）？

'''

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

'''

Answer 1

试试这个。 代码中的注释。

Sub CompareColumns()
    Dim cols As Collection, headerList, header, n As Long, i As Long, j As Long
    Dim rng As Range, v, wb As Workbook
    
    headerList = Array("abc", "def", "ghi") 'column headers to compare
    Set wb = ThisWorkbook
    
    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?
            ResetFill cols                    'clear previous flags
            For i = 1 To cols(1).Cells.Count  'column length
                v = cols(1)(i)                'read value from first column
                For j = 2 To cols.Count       'check other columns
                    If cols(j).Cells(i).Value <> v Then   'mismatch?
                        For Each rng In cols  'flag all columns at this position
                            rng.Cells(i).Interior.Color = vbRed
                        Next rng
                        Exit For              'done checking
                    End If
                Next j
            Next i
        End If
    Next header
End Sub

'Check all sheet in workbook `wb` for a 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
    Const HEADER_ROW As Long = 2
    Dim ws As Worksheet, col As New Collection, maxRow As Long, lr As Long
    Dim rng As Range, m, i As Long
    For Each ws In wb.Worksheets
        m = Application.Match(hdr, ws.Rows(HEADER_ROW), 0)
        If Not IsError(m) Then
            col.Add ws.Cells(HEADER_ROW + 1, m) 'first value cell
            lr = ws.Cells(Rows.Count, m).End(xlUp).Row
            If lr > maxRow Then maxRow = lr
        End If
    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