Hey there! I see your script is freezing up halfway through processing 83k rows, even with manual calculation and screen updates turned off. The main culprit here is the repeated full-column CountIf calls—each iteration scans the entire B column, which adds up to an O(n²) operation that’s brutal for large datasets. Let’s fix this with smarter caching, batch operations, and small tweaks to keep Excel responsive while showing clear progress.

Key Optimizations to Fix Freezes & Improve Progress Visibility #

• Cache B column values in a Dictionary: This turns slow full-column scans into near-instant lookups.
• Batch-write results to cells: Writing to cells one-by-one is slow—store results in an array first, then dump them all at once.
• Use DoEvents periodically: Let Excel catch up on UI updates and system events to prevent freezing.
• Update the status bar less frequently: Reducing unnecessary UI updates saves resources.

Modified VBA Code #

Sub MacroToCreateReducedBoMList()
    Dim LR As Long, i As Long, j As Long
    Dim LastRow As Long
    Dim StartCell As Range
    Dim Calc_Setting As Long
    Dim StartTime As Double
    Dim MinutesElapsed As String
    Dim bColDict As Object ' Dictionary to cache column B values
    Dim resultsArray() As Variant ' Array to store results for batch write
    
    StartTime = Timer
    
    ' Save original settings
    Calc_Setting = Application.Calculation
    Dim EventState As Boolean: EventState = Application.EnableEvents
    Dim PageBreakState As Boolean: PageBreakState = ActiveSheet.DisplayPageBreaks
    
    ' Disable resource-heavy features
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.ScreenUpdating = False
    
    Set StartCell = Range("A1")
    LastRow = StartCell.SpecialCells(xlCellTypeLastCell).Row
    j = 1 ' Index for results array
    
    ' Initialize dictionary and cache column B values
    Set bColDict = CreateObject("Scripting.Dictionary")
    For i = 2 To LastRow
        If Not IsEmpty(Range("B" & i)) Then
            ' Store unique values (case-insensitive by default; add ,True for case-sensitive)
            If Not bColDict.Exists(Range("B" & i).Value) Then
                bColDict.Add Range("B" & i).Value, True
            End If
        End If
        ' Update status bar while building the dictionary
        If i Mod 100 = 0 Then
            Application.StatusBar = "Caching column B: " & i & "/" & LastRow
            DoEvents ' Let Excel respond
        End If
    Next i
    
    ' Resize results array to maximum possible rows (adjust if needed)
    ReDim resultsArray(1 To LastRow - 1, 1 To 3) ' 3 columns for F, G, H
    
    ' MAIN LOOP: Check column A against dictionary
    For i = 2 To LastRow
        If Not bColDict.Exists(Range("A" & i).Value) Then
            ' Add to results array instead of writing directly to cells
            resultsArray(j, 1) = Range("A" & i).Value
            resultsArray(j, 2) = Range("B" & i).Value
            resultsArray(j, 3) = Range("C" & i).Value
            j = j + 1
        End If
        
        ' Update status bar every 100 iterations (adjust as needed)
        If i Mod 100 = 0 Then
            Application.StatusBar = "Processing rows: " & i & "/" & LastRow & " | Found " & j - 1 & " matches so far"
            DoEvents ' Prevent freeze by letting Excel handle UI/system events
        End If
    Next i
    
    ' Clear old results and write new ones in one go
    Range("F2:H" & LastRow).ClearContents
    If j > 1 Then
        ' Write only the filled part of the array
        Range("F2").Resize(j - 1, 3).Value = resultsArray
    End If
    
    ' Restore original settings
    Application.ScreenUpdating = True
    Application.Calculation = Calc_Setting
    Application.EnableEvents = EventState
    ActiveSheet.DisplayPageBreaks = PageBreakState
    
    ' Calculate elapsed time
    MinutesElapsed = Format((Timer - StartTime) / 86400, "hh:mm:ss")
    MsgBox "This code ran successfully in " & MinutesElapsed & vbNewLine & "Total matches found: " & j - 1, vbInformation
    
    ' Reset status bar
    Application.StatusBar = False
End Sub

What’s Changed & Why? #

1. Dictionary Caching: We first load all unique values from column B into a dictionary. Looking up values here is O(1) instead of O(n) per iteration—this alone will cut execution time drastically.
2. Batch Array Writing: Instead of writing to F:H cells one by one, we store results in an array and write everything at the end. Cell operations are slow, so this reduces overhead.
3. DoEvents Every 100 Iterations: This tells Excel to pause processing briefly to update the status bar, respond to system events, and avoid appearing frozen. You can adjust the 100 to a lower/higher number if needed (e.g., 50 for more frequent updates, 200 for slightly faster execution).
4. Status Bar Updates: We only update the status bar every 100 rows, which reduces UI overhead while still keeping users informed. We also add a count of found matches to give more context.

Quick Notes #

• Make sure the Microsoft Scripting Runtime reference is enabled if you want to use early binding (replace CreateObject("Scripting.Dictionary") with New Dictionary). If not, late binding (as shown) works fine without references.
• The script now shows how many matches have been found so far, which helps users track progress better.
• Even with these changes, processing 83k rows will take some time, but Excel won’t freeze up, and the status bar will stay responsive.

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