比较第 1 列和第 2 列中的每一行，突出显示差异并将差异填充到另一张表格中

Question

我是 VBA 新手，我有一个比较两列的任务。宏应该将活动工作表中每一列上的条目与另一列进行比较，并突出显示差异。它还将两列的不同值添加到另一个工作表中。我在 google 和 youtube 的帮助下创建了代码，并且运行良好。但问题是，如果我们输入大约 30000 行左右，宏需要更多时间来完成任务。有什么办法可以减少时间。我已经粘贴了下面的代码。请检查并提出建议。

'Looping into the columns'

     For r = 2 To LastRow
         Row2inCol1 = Cells(r, Column1.Column).Value
         Row2inCol2 = Cells(r, Column2.Column).Value

    'Searching 1st row of column1 with column2

    If Row2inCol1 <> "" Then
        Set inCol2 = Column2.Find(Row2inCol1)
            If inCol2 Is Nothing Then
                Cells(r, Column1.Column).Interior.ColorIndex = 31
                'Adding highlighted results in different sheet
                Col1Diff = Col1Diff + 1
                Sheets("Results").Cells(Col1Diff + 1, 1).Value = Row2inCol1
            End If
    End If


    'Searching "2nd row of column2 with column1
    
    If Row2inCol2 <> "" Then
        Set inCol1 = Column1.Find(Row2inCol2)
            If inCol1 Is Nothing Then
                Cells(r, Column2.Column).Interior.ColorIndex = 31
                'Adding highlighted results in different sheet
                Col2Diff = Col2Diff + 1
                Sheets("Results").Cells(Col2Diff + 1, 2).Value = Row2inCol2
            End If
    End If
Next r

Answer 1

• 利用Dictionary对象获取唯一列表并找出差异。
• 通过将数据加载到数组中来提高效率。

微软文档：

字典对象

应用程序.Union方法（Excel）

Range.End 属性 (Excel)

Option Explicit

Sub CompareTwoCols()
    Dim oSht1 As Worksheet, oSht2 As Worksheet, LastRow As Long
    Dim arrData1, arrData2
    Const COL1 = "A"  ' modify as needed
    Const COL2 = "B"
    Set oSht1 = Sheets("Sheet1")  ' modify as needed
    Set oSht2 = Sheets("Results")
    ' Load data into array
    With oSht1
        LastRow = .Cells(.Rows.Count, COL1).End(xlUp).Row
        arrData1 = .Cells(1, COL1).Resize(LastRow).Value
        LastRow = .Cells(.Rows.Count, COL2).End(xlUp).Row
        arrData2 = .Cells(1, COL2).Resize(LastRow).Value
    End With
    ' COL1 vs COL2
    CompareCol oSht1, COL1, arrData1, arrData2, oSht2.Range("A1")
    ' COL2 vs COL1
    CompareCol oSht1, COL2, arrData2, arrData1, oSht2.Range("B1")
End Sub

Sub CompareCol(oSht1 As Worksheet, baseCol, arrA, arrB, rTargetCell As Range)
    Dim i As Long, rDiff As Range
    Dim objDic2 As Object, sKey As String, objDicRes As Object
    Set objDic2 = CreateObject("scripting.dictionary")
    Set objDicRes = CreateObject("scripting.dictionary")
    With oSht1
        ' Load data into Dict
        For i = LBound(arrB) + 1 To UBound(arrB)
            arrB(i, 1) = CStr(arrB(i, 1))
            objDic2(arrB(i, 1)) = ""
        Next i
        ' Loop through data on baseCol
        For i = LBound(arrA) + 1 To UBound(arrA)
            sKey = CStr(arrA(i, 1))
            If Not objDic2.exists(sKey) Then
                ' Get the different item (unique list)
                objDicRes(sKey) = ""
                ' Get the cell refer
                If rDiff Is Nothing Then
                    Set rDiff = .Cells(i, baseCol)
                Else
                    Set rDiff = Application.Union(rDiff, .Cells(i, baseCol))
                End If
            End If
        Next i
        ' Highlight cell(s)
        If Not rDiff Is Nothing Then
            .Columns(baseCol).Interior.Color = xlNone
            rDiff.Interior.ColorIndex = 31
        End If
        ' Write ouput to sheet
        rTargetCell.EntireColumn.ClearContents
        rTargetCell.Resize(objDicRes.Count, 1) = Application.Transpose(objDicRes.keys)
    End With
End Sub