基于A列唯一值提取B列唯一值的Excel VBA宏脚本需求

Got it, let's fix that slow calculation problem for your 50k rows of data. The formula approach is way too inefficient for large datasets, so this VBA macro will handle the unique pair extraction in seconds instead of minutes, and it's fully compatible with .xls files (no pivot table or modern format restrictions).

The Macro Code #

Sub ExtractUniquePairs()
    Dim ws As Worksheet
    Dim sourceData As Variant
    Dim uniquePairs As Object
    Dim i As Long
    Dim key As String
    Dim outputArray As Variant
    Dim outputIndex As Long
    
    ' Speed up execution by disabling screen updates and events
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' Set the worksheet (change to your sheet name if needed)
    Set ws = ActiveSheet
    ' Get all source data from columns A and B (assuming data starts at row 2)
    sourceData = ws.Range("A2:B" & ws.Cells(ws.Rows.Count, "A").End(xlUp).Row).Value
    
    ' Initialize dictionary to track unique pairs (late binding for .xls compatibility)
    Set uniquePairs = CreateObject("Scripting.Dictionary")
    uniquePairs.CompareMode = vbTextCompare ' Case-insensitive, change to vbBinaryCompare if needed
    
    ' Iterate through source data to collect unique pairs
    For i = LBound(sourceData, 1) To UBound(sourceData, 1)
        ' Create a unique key by combining date and color with a delimiter
        key = sourceData(i, 1) & "|" & sourceData(i, 2)
        If Not uniquePairs.Exists(key) Then
            uniquePairs.Add key, Array(sourceData(i, 1), sourceData(i, 2))
        End If
    Next i
    
    ' Prepare output array
    ReDim outputArray(1 To uniquePairs.Count, 1 To 2)
    outputIndex = 1
    For Each key In uniquePairs.Keys
        outputArray(outputIndex, 1) = uniquePairs(key)(0)
        outputArray(outputIndex, 2) = uniquePairs(key)(1)
        outputIndex = outputIndex + 1
    Next key
    
    ' Write output to columns C and D (starting at row 2)
    ws.Range("C2:D" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row).ClearContents ' Clear existing data
    ws.Range("C2").Resize(UBound(outputArray, 1), 2).Value = outputArray
    
    ' Cleanup and restore settings
    Set uniquePairs = Nothing
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    
    MsgBox "Unique pairs extracted successfully!", vbInformation
End Sub

How to Use This Macro #

1. Open your Excel .xls file.
2. Press Alt + F11 to open the VBA Editor.
3. Right-click your workbook in the Project Explorer > Insert > Module.
4. Paste the code above into the new module.
5. Press F5 to run the macro, or assign it to a button for easier access.

Key Optimizations for Speed #

• Array Processing: We load all source data into a single array first, avoiding slow cell-by-cell interactions.
• Dictionary Lookup: The Scripting.Dictionary provides near-instant lookups to check for existing pairs, which is way faster than formula-based checks.
• Disabled Screen Updates: Turning off screen updates and events cuts down on unnecessary overhead during execution.

Notes #

• The macro assumes your data starts at row 2 (with headers in row 1). Adjust the range references if your data starts elsewhere.
• The pair comparison is case-insensitive (e.g., "Red" and "red" are treated as the same). If you need case-sensitive checks, change vbTextCompare to vbBinaryCompare in the code.
• The output will be written to columns C and D, starting at row 2. Any existing data in these columns will be cleared before writing the new results.

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