编写VBA程序：跨工作表对比列、高亮差异并替换相同单元格为序号

Alright, let's build those two VBA macros you need. I'll walk you through each one with fully commented code and customization tips so you can adapt them to your exact data setup.

This macro will scan two columns in the same sheet, highlight any cells that don't match, and overwrite matching cells with a value of your choice. No pre-sorting required here either.

Sub CompareSameSheetColumns()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim compareCol1 As String, compareCol2 As String
    Dim highlightColor As Long
    Dim replaceValue As Variant
    
    ' ----------------------
    ' Customize these values to match your needs
    ' ----------------------
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' Target worksheet name
    compareCol1 = "A" ' First column to compare
    compareCol2 = "B" ' Second column to compare
    highlightColor = vbYellow ' Color for mismatched cells
    replaceValue = "Matched" ' Value to replace matching cells with
    
    ' Get the last row with data (takes the max of both columns)
    lastRow = Application.Max(ws.Cells(ws.Rows.Count, compareCol1).End(xlUp).Row, _
                              ws.Cells(ws.Rows.Count, compareCol2).End(xlUp).Row)
    
    ' Loop through each row to compare values
    For i = 1 To lastRow
        ' Check if both cells have data
        If Not IsEmpty(ws.Cells(i, compareCol1)) And Not IsEmpty(ws.Cells(i, compareCol2)) Then
            If ws.Cells(i, compareCol1).Value <> ws.Cells(i, compareCol2).Value Then
                ' Highlight mismatched cells
                ws.Cells(i, compareCol1).Interior.Color = highlightColor
                ws.Cells(i, compareCol2).Interior.Color = highlightColor
            Else
                ' Replace matching cells with your chosen value
                ws.Cells(i, compareCol1).Value = replaceValue
                ws.Cells(i, compareCol2).Value = replaceValue
            End If
        Else
            ' Highlight cells where one is empty (adjust this if you don't want this behavior)
            ws.Cells(i, compareCol1).Interior.Color = highlightColor
            ws.Cells(i, compareCol2).Interior.Color = highlightColor
        End If
    Next i
    
    MsgBox "Same-sheet comparison complete!", vbInformation
End Sub

How to use this: #

• Open the VBA editor with Alt + F11
• Insert a new module (right-click your workbook in the Project Explorer > Insert > Module)
• Paste the code above
• Adjust the custom parameters (worksheet name, columns, highlight color, replace value) to fit your data
• Run the macro (press F5 in the editor, or use the Macro dialog from the Developer tab)

This macro works across two separate sheets, highlights mismatches, and replaces matching values with unique sequential numbers—no pre-sorting required. We'll use a dictionary to track which values have already been assigned a number, so duplicates get the same ID.

Sub CompareDifferentSheets()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lastRow1 As Long, lastRow2 As Long
    Dim i As Long, j As Long
    Dim compareCol1 As String, compareCol2 As String
    Dim highlightColor As Long
    Dim matchDict As Object
    Dim currentSeq As Integer
    
    ' ----------------------
    ' Customize these values to match your needs
    ' ----------------------
    Set ws1 = ThisWorkbook.Worksheets("Sheet1") ' First worksheet name
    Set ws2 = ThisWorkbook.Worksheets("Sheet2") ' Second worksheet name
    compareCol1 = "A" ' Column to check in first sheet
    compareCol2 = "B" ' Column to check in second sheet
    highlightColor = vbCyan ' Color for mismatched cells
    currentSeq = 1 ' Starting number for sequential IDs
    
    ' Create a dictionary to track matched values and their IDs
    Set matchDict = CreateObject("Scripting.Dictionary")
    
    ' Get last row with data for both sheets
    lastRow1 = ws1.Cells(ws1.Rows.Count, compareCol1).End(xlUp).Row
    lastRow2 = ws2.Cells(ws2.Rows.Count, compareCol2).End(xlUp).Row
    
    ' First pass: Scan Sheet1, replace matches with IDs, highlight mismatches
    For i = 1 To lastRow1
        Dim isMatched As Boolean
        isMatched = False
        
        ' Look for a match in Sheet2
        For j = 1 To lastRow2
            If ws1.Cells(i, compareCol1).Value = ws2.Cells(j, compareCol2).Value Then
                isMatched = True
                ' Assign a new ID if this value hasn't been seen before
                If Not matchDict.Exists(ws1.Cells(i, compareCol1).Value) Then
                    matchDict.Add ws1.Cells(i, compareCol1).Value, currentSeq
                    currentSeq = currentSeq + 1
                End If
                ' Replace both matching cells with the assigned ID
                ws1.Cells(i, compareCol1).Value = matchDict(ws1.Cells(i, compareCol1).Value)
                ws2.Cells(j, compareCol2).Value = matchDict(ws2.Cells(j, compareCol2).Value)
                Exit For ' Stop searching once a match is found
            End If
        Next j
        
        ' Highlight if no match was found
        If Not isMatched Then
            ws1.Cells(i, compareCol1).Interior.Color = highlightColor
        End If
    Next i
    
    ' Second pass: Scan Sheet2 to highlight any remaining mismatches
    For j = 1 To lastRow2
        Dim hasMatch As Boolean
        hasMatch = False
        
        For i = 1 To lastRow1
            If ws2.Cells(j, compareCol2).Value = ws1.Cells(i, compareCol1).Value Then
                hasMatch = True
                Exit For
            End If
        Next i
        
        If Not hasMatch Then
            ws2.Cells(j, compareCol2).Interior.Color = highlightColor
        End If
    Next j
    
    MsgBox "Cross-sheet comparison complete!", vbInformation
    Set matchDict = Nothing ' Clean up the dictionary object
End Sub

How to use this: #

• Follow the same steps as the first macro to insert the code
• Adjust the worksheet names, columns, highlight color, and starting number to fit your data
• Run the macro—no need to sort your data first, the dictionary handles tracking matches regardless of order

内容的提问来源于stack exchange，提问作者Fatima Ali