这应该更快。它使用两个字典来Map两个数组中每个id的行位置。还使用一个数组来捕获输出（你可能需要一些更聪明的方式来分配初始大小.），这样你就可以在一次赋值中写入结果。
在我的电脑上比较两张大约90 k行x 8列的表格只花了3秒多。

注意-我省略了列标题检查，因为我无法理解你使用的逻辑。你检查标题是否也在第二个工作表上，但你没有验证标题 * 位置 * 是否与第一个工作表相同.使用Find()比使用Application.Match慢得多，所以至少考虑在现有代码中测试这种变化。

Sub CompareSheetsAndLogChangesColumnB()
    Const SHT_A As String = "Sheet1"
    Const SHT_B As String = "Sheet2"
    
    Dim wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
    Dim cellA As Range, cellB As Range
    Dim pernums1 As Object, pernums2 As Object, k
    Dim pernum As String, changeInfo As String, sep As String
    Dim data1 As Variant, data2 As Variant, t
    Dim dataOut(1 To 10000, 1 To 2) 'size to max expected lines * 2 maybe
    Dim i As Long, j As Long, changeRow As Long, maxCols As Long, rowNum As Long
    
    t = Timer
    
    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets(SHT_A)
    Set ws2 = wb.Sheets(SHT_B)
    Set ws3 = wb.Sheets("Sheet3")
    
    ws3.Cells.Clear
    ws3.Cells(1, 1).Value = "Personal Number"
    ws3.Cells(1, 2).Value = "Explanation"
    
    data1 = ws1.UsedRange.Value
    data2 = ws2.UsedRange.Value
    maxCols = Application.Min(UBound(data1, 2), UBound(data2, 2)) 'max# of cols to compare
    
    'map unique values in col2 to their row indexes
    Set pernums1 = RowMap(data1, 2, 1) '1=skip header row
    Set pernums2 = RowMap(data2, 2, 1)
    changeRow = 0
    
    For i = 2 To UBound(data1, 1)
        pernum = CStr(data1(i, 2))
        
        If Not pernums2.exists(pernum) Then
            AddMessage dataOut, changeRow, pernum, "Not found on sheet " & SHT_B
        Else
            rowNum = pernums2(pernum)
            changeInfo = ""
            sep = ""
            For j = 1 To maxCols
                If data1(i, j) <> data2(rowNum, j) Then
                    changeInfo = changeInfo & sep & "Column '" & data1(1, j) & _
                                  "' changed from '" & data1(i, j) & _
                                  "' to '" & data2(rowNum, j) & "'"
                    sep = ", "
                End If
            Next j
            If Len(changeInfo) > 0 Then AddMessage dataOut, changeRow, pernum, changeInfo
        End If
    Next i
    
    'check for any id's on sheet2 not on sheet1
    For Each k In pernums2
        If Not pernums1.exists(CStr(k)) Then
            AddMessage dataOut, changeRow, CStr(k), "Not found on sheet " & SHT_A
        End If
    Next k
    
    If changeRow > 0 Then 'any changes to log?
       ws3.Range("A2").Resize(changeRow, 2).Value = dataOut
    End If
    
    Debug.Print Timer - t
    
End Sub

'Map unique values in column `idCol` of 2D array `data`
'  to the row index they're found on. Optionally ignore first
'  `skipHeaders` rows in the array
Function RowMap(data As Variant, idCol As Long, _
                Optional skipHeaders As Long = 0) As Object
    Dim r As Long, rStart As Long, v
    Set RowMap = CreateObject("Scripting.Dictionary")
    rStart = LBound(data, 1) + skipHeaders
    For r = rStart To UBound(data, 1)
        v = data(r, idCol)
        If Len(v) > 0 Then RowMap.Add CStr(v), r 'assumes data in column `idCol` is unique
    Next r
End Function

'add a new "line" to the array `dataOut` and increment the counter `changeRow`
Sub AddMessage(dataOut, ByRef changeRow As Long, pernum As String, msg As String)
    changeRow = changeRow + 1
    dataOut(changeRow, 1) = pernum
    dataOut(changeRow, 2) = msg
End Sub

字符串

它的编写方式似乎可以，如果它做你想要的，但你是重新计算电子表格和重新绘制屏幕上的任何变化是从电子表格，这可能是冰川缓慢！
如果你把现有的代码与禁用屏幕更新和设置计算手动它应该是一个很多快.足够快可能仍然是一个问题，虽然-这肯定是第一件事尝试快速加速.
当你离开你的日常生活时，记得把它重置回正常状态！
示例代码

Sub faster()
Application.Calculation = False
Application.ScreenUpdating = xlManual

''your stuff here

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub

字符串

你的代码看起来不错。你为范围分配范围的部分非常好，将为你保存很多时间。
然而，有一些规则可以让你的代码更快，在写新代码的时候，你应该记住这些规则。
规则#1.计算
通常，如果单元格或区域中的值发生更改，Excel将重新计算所有单元格、公式和条件格式。这可能会导致工作簿重新计算的频率过高，从而降低性能。您可以使用以下语句阻止Excel重新计算工作簿：

Application.Calculation = xlCalculationManual

字符串
在代码的末尾，您可以使用以下语句将计算模式设置回自动：

Application.Calculation = xlCalculationAutomatic

型
但请记住，当计算模式为xlCalculationManual时，Excel不会更新单元格中的值。如果宏依赖于更新的单元格值，则必须使用.Calculate方法（如Worksheets(1).Calculate.）强制执行Calculate事件

规则2.屏幕更新

正如同事们在评论中已经提到的，你已经可以从这个命令中得到很多东西。
问题是，每次将数据写入工作表时，它都会刷新您看到的屏幕图像。刷新图像对性能的影响相当大。以下命令关闭屏幕更新。

Application.ScreenUpdating = FALSE

型
在宏结束时，使用以下命令重新打开屏幕更新。

Application.ScreenUpdating = TRUE

型
规则#3使用语句
您经常会多次操作同一个对象。通过使用With语句一次性对给定对象执行多个操作，可以保存时间并提高性能。
下面的示例中使用的With语句告诉Excel一次应用所有格式更改：

With Range("A1").Font
.Bold = True
.Italic = True
.Underline = xlUnderlineStyleSingle
End With

型
With语句示例：
您的代码

For i = 2 To UBound(data2, 1)
            pernum = Data(i, 2)
            If Not pernums.Exists(pernum) Then
                ws3.Cells(changeRow, 1).Value = pernum
                ws3.Cells(changeRow, 2).Value = "Not Found in the first sheet"
                changeRow = changeRow + 1
            End If
        Next i

型
使用语句进行编码

With ws3
    For i = 2 To UBound(data2, 1)
            pernum = Data(i, 2)
            If Not pernums.Exists(pernum) Then
                .Cells(changeRow, 1).Value = pernum
                .Cells(changeRow, 2).Value = "Not Found in the first sheet"
                changeRow = changeRow + 1
            End If
        Next i
End With

型
在我的电脑上，使用With Statment的相同代码大约需要15到16秒。
养成将动作分块到With语句中的习惯不仅可以让宏运行得更快，还可以让宏代码更容易阅读。

规则#4忽略事件

如果您为工作簿的Sheet1实现了一个EQUIPMENT_Change事件。任何时候Sheet1上的单元格或区域被更改，EQUIPMENT_Change事件都会运行。因此，如果您有一个标准宏操作Sheet1上的多个单元格，那么每当该工作表上的单元格被更改时，您的宏必须在EQUIPMENT_Change事件运行时暂停。您可以想象这种行为会如何减慢宏的速度。

Application.EnableEvents = False

型
在代码的末尾，可以使用以下语句将EnableEvents模式设置回True：

Application.EnableEvents = True

型

日志表变更

的数据

的

主要

Sub LogSheetChanges()
    Const PROC_TITLE As String = "Log Sheet Changes"
    On Error GoTo ClearError
    
    Const FIRST_SHEET_NAME As String = "Sheet1"
    Const FIRST_PERNUM_COLUMN As Long = 2
    Const SECOND_SHEET_NAME As String = "Sheet2"
    Const DST_SHEET_NAME As String = "Sheet3"
    Const DST_FIRST_CELL As String = "A1"
    Const DST_COLUMNS_COUNT As Long = 2
    Const DST_CHANGE_DELIMITER As String = ", "
    Const DST_HEADER_DELIMITER As String = ": "
    Dim dHeaders() As Variant:
    dHeaders = Array("Personal Number", "Explanation")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' First
    
    Dim hrg As Range, fpnrg As Range, hData() As Variant, fData() As Variant
    Dim cCount As Long, frCount As Long
    
    If Not GetFirst(wb, FIRST_SHEET_NAME, FIRST_PERNUM_COLUMN, _
        hrg, fpnrg, hData, fData, cCount, frCount) Then Exit Sub
    
    ' Second
        
    Dim spnrg As Range, sData() As Variant, scIndices() As Variant
    Dim srCount As Long, SecondPernumColumn As Long
    
    If Not GetSecond(wb, SECOND_SHEET_NAME, hrg, FIRST_PERNUM_COLUMN, _
        spnrg, sData, scIndices, srCount, SecondPernumColumn) Then Exit Sub
    
    ' Indices
    
    Dim fcIndices() As Variant
    
    If Not GetColumnIndices(FIRST_PERNUM_COLUMN, _
        fcIndices, scIndices, cCount) Then Exit Sub
    
    Dim srIndices() As Variant: srIndices = Application.Match(fpnrg, spnrg, 0)
    Dim frIndices() As Variant: frIndices = Application.Match(spnrg, fpnrg, 0)
    
    ' Destination Array
    
    Dim dData() As Variant, drCount As Long
    
    If Not PopulateDestinationArray(hData, fData, sData, frIndices, srIndices, _
        fcIndices, scIndices, FIRST_PERNUM_COLUMN, SecondPernumColumn, _
        frCount, srCount, cCount, DST_COLUMNS_COUNT, DST_CHANGE_DELIMITER, _
        DST_HEADER_DELIMITER, dData, drCount) Then Exit Sub
    
    ' Destination Range
    
    If Not PopulateDestinationRange(wb, DST_SHEET_NAME, DST_FIRST_CELL, _
        dHeaders, dData, drCount, DST_COLUMNS_COUNT) Then Exit Sub
    
    ' Inform.
    
    MsgBox "Changes logged.", vbInformation, PROC_TITLE

ProcExit:
    Exit Sub
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub

字符串

帮助1

Function GetFirst( _
    ByVal wb As Workbook, _
    ByVal FirstSheetName As String, _
    ByVal FirstPernumColumn As Long, _
    hrg As Range, _
    fpnrg As Range, _
    ByRef hData() As Variant, _
    ByRef fData() As Variant, _
    ByRef cCount As Long, _
    ByRef frCount As Long) _
As Boolean
    Const PROC_TITLE As String = "Get First"
    On Error GoTo ClearError

    Dim ws As Worksheet: Set ws = wb.Sheets(FirstSheetName)
    
    With ws.UsedRange
        frCount = .Rows.Count - 1 ' exclude headers
        If frCount = 0 Then
            MsgBox "No data in worksheet """ & ws.Name & """ of workbook """ _
                & wb.Name & """!", vbExclamation, PROC_TITLE
            Exit Function
        End If
        Set hrg = .Rows(1)
        hData = hrg.Value
        cCount = .Columns.Count
        With .Resize(frCount).Offset(1)
            Set fpnrg = .Columns(FirstPernumColumn)
            fData = .Value
        End With
    End With

    GetFirst = True
    
ProcExit:
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

型

帮助2

Function GetSecond( _
    ByVal wb As Workbook, _
    ByVal SecondSheetName As String, _
    ByVal hrg As Range, _
    ByVal FirstPernumColumn As Long, _
    spnrg As Range, _
    ByRef sData() As Variant, _
    ByRef scIndices() As Variant, _
    ByRef srCount As Long, _
    ByRef SecondPernumColumn As Long) _
As Boolean
    Const PROC_TITLE As String = "Get Second"
    On Error GoTo ClearError

    Dim ws As Worksheet: Set ws = wb.Sheets(SecondSheetName)
    
    With ws.UsedRange
         Debug.Print .Address
        srCount = .Rows.Count - 1 ' exclude headers
        If srCount = 0 Then
            MsgBox "No data in worksheet """ & ws.Name & """ of workbook """ _
                & wb.Name & """!", vbExclamation, PROC_TITLE
            Exit Function
        End If
        scIndices = Application.Match(hrg, .Rows(1), 0)
        Dim spnc As Variant: spnc = scIndices(FirstPernumColumn)
        If IsNumeric(spnc) Then
            SecondPernumColumn = spnc
        Else
            MsgBox "Second personal number column not found!", _
                vbExclamation, PROC_TITLE
            Exit Function
        End If
        With .Resize(srCount).Offset(1)
            Set spnrg = .Columns(SecondPernumColumn)
            sData = .Value
        End With
    End With
    
    GetSecond = True
    
ProcExit:
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

型

帮助3

Function GetColumnIndices( _
    ByVal FirstPernumColumn As Long, _
    ByRef fcIndices() As Variant, _
    ByRef scIndices() As Variant, _
    ByRef cCount As Long) _
As Boolean
    Const PROC_TITLE As String = "Get Column Indices"
    On Error GoTo ClearError

    ReDim fcIndices(1 To cCount)
    
    Dim fc As Long, sc As Long
    
    For fc = 1 To cCount
        If fc <> FirstPernumColumn Then
            If IsNumeric(scIndices(fc)) Then
                sc = sc + 1
                fcIndices(sc) = fc
                scIndices(sc) = scIndices(fc)
            End If
        End If
    Next fc
    
    If sc = 0 Then
        MsgBox "No matching columns found!", vbExclamation, PROC_TITLE
        Exit Function
    End If
    
    cCount = sc
    
    ReDim Preserve fcIndices(1 To cCount)
    ReDim Preserve scIndices(1 To cCount)
    
    GetColumnIndices = True

ProcExit:
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

型

帮助4

Function PopulateDestinationArray( _
    hData() As Variant, _
    fData() As Variant, _
    sData() As Variant, _
    frIndices() As Variant, _
    srIndices() As Variant, _
    fcIndices() As Variant, _
    scIndices() As Variant, _
    ByVal FirstPernumColumn As Long, _
    ByVal SecondPernumColumn As Long, _
    ByVal frCount As Long, _
    ByVal srCount As Long, _
    ByVal cCount As Long, _
    ByVal dcCount As Long, _
    ByVal ChangeDelimiter As String, _
    ByVal HeaderDelimiter As String, _
    ByRef dData() As Variant, _
    ByRef drCount As Long) _
As Boolean
    Const PROC_TITLE As String = "Populate Destination Array"
    On Error GoTo ClearError
    
    drCount = frCount + srCount - Application.Count(frIndices)
    ReDim dData(1 To drCount, 1 To dcCount)
    
    Dim cdLen As Long: cdLen = Len(ChangeDelimiter)
    
    Dim fr As Long, sr As Variant, dr As Long, fc As Long, c As Long
    Dim fStr As String, sStr As String, dStr As String, LogNot As Boolean
    
    For fr = 1 To frCount
        sr = srIndices(fr, 1)
        If IsNumeric(sr) Then ' personal found in second
            For c = 1 To cCount
                fc = fcIndices(c)
                fStr = CStr(fData(fr, fc))
                sStr = CStr(sData(sr, scIndices(c)))
                If StrComp(fStr, sStr, vbTextCompare) <> 0 Then
                    dStr = dStr & hData(1, fc) & HeaderDelimiter _
                        & fStr & " changed to " & sStr _
                        & ChangeDelimiter
                End If
            Next c
            If Len(dStr) = 0 Then
                LogNot = True
            Else
                dStr = Left(dStr, Len(dStr) - cdLen)
            End If
        Else ' personal not found in second
            dStr = "Not found in second sheet."
        End If
        If LogNot Then
            LogNot = False
        Else
            dr = dr + 1
            dData(dr, 1) = fData(fr, FirstPernumColumn)
            dData(dr, 2) = dStr
            dStr = vbNullString
        End If
    Next fr
    
    For sr = 1 To srCount
        If IsError(frIndices(sr, 1)) Then
            dr = dr + 1
            dData(dr, 1) = sData(sr, SecondPernumColumn)
            dData(dr, 2) = "Not found in first sheet."
        End If
    Next sr
    
    If dr < drCount Then drCount = dr
    
    PopulateDestinationArray = True

ProcExit:
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

型

帮助5

Function PopulateDestinationRange( _
    ByVal wb As Workbook, _
    ByVal SheetName As String, _
    ByVal FirstCellAddress As String, _
    dHeaders() As Variant, _
    dData() As Variant, _
    ByVal drCount As Long, _
    ByVal dcCount As Long) _
As Boolean
    Const PROC_TITLE As String = "Populate Destination Range"
    On Error GoTo ClearError
    
    Dim ws As Worksheet: Set ws = wb.Sheets(SheetName)
    
    With ws.Range(FirstCellAddress).Resize(, dcCount)
        ' Write headers.
        .Value = dHeaders
        ' Write data.
        .Offset(1).Resize(drCount).Value = dData
        ' Clear below.
        .Resize(ws.Rows.Count - .Row - drCount).Offset(drCount + 1).Clear
        ' Format.
        .Font.Bold = True
        .EntireColumn.AutoFit
    End With

    PopulateDestinationRange = True

ProcExit:
    Exit Function
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Function

型