VBA宏优化：停止使用临时区域及解决集合键值获取问题

Hey there! As a fellow VBA enthusiast, I totally get where you're coming from—starting out, it's easy to get things working but miss those efficiency wins and small syntax gotchas. Let's fix your two main issues and get your macro running smooth and fast.

First, Let's Diagnose the Core Problems #

1. The Collection Mix-Up #

Your biggest immediate issue is that you've got the Collection.Add parameters backwards! The syntax is:

collection.Add Item, [Key], [Before], [After]

Your code has:

allNames.Add (allNames.count), SubString(j)

This means you're adding the count/序号 as the Item, and the name as the Key. So when you call allNames.Key(k) or allNames(k), you're getting the count value instead of the name. Oops! We need to flip those around.

2. Efficiency Drags #

Your original code writes to the worksheet in a loop and then clears temporary ranges—this is slow because worksheet interactions are the most expensive operation in VBA. We can fix this by:

• Using arrays to build our output first, then writing everything to the sheet in one go.
• Avoiding unnecessary range clears and loops that touch cells repeatedly.

Optimized Code Solution #

Here's the revised macro with fixes for both issues, plus efficiency boosts:

Sub FindUniquesOptimized()
    Dim wsSource As Worksheet, wsOutput As Worksheet
    Dim lastRow As Long, i As Long, j As Long, collIndex As Long
    Dim nameParts() As String
    Dim uniqueNames As New Collection
    Dim outputArray() As Variant
    Dim outputRow As Long
    
    ' Set worksheet references (use explicit names to avoid errors)
    On Error Resume Next
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
    On Error GoTo 0
    
    ' Check if worksheets exist (avoid runtime errors)
    If wsSource Is Nothing Or wsOutput Is Nothing Then
        MsgBox "Sheet1 or Sheet2 not found! Make sure both sheets exist.", vbExclamation
        Exit Sub
    End If
    
    ' Get the last used row in column A (more reliable than End(xlDown))
    lastRow = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row
    
    ' Extract and deduplicate names
    On Error Resume Next ' Only catch duplicate key errors
    For i = 1 To lastRow
        ' Skip empty cells
        If Trim(wsSource.Cells(i, "A").Value) <> "" Then
            ' Split names by comma + space
            nameParts = Split(wsSource.Cells(i, "A").Value, ", ")
            
            ' Add each name to the collection (key = name to enforce uniqueness)
            For j = 0 To UBound(nameParts)
                ' Add name as both Item and Key (Key must be unique)
                uniqueNames.Add Item:=Trim(nameParts(j)), Key:=Trim(nameParts(j))
            Next j
        End If
    Next i
    On Error GoTo 0 ' Reset error handling
    
    ' If no names were found, exit early
    If uniqueNames.Count = 0 Then
        MsgBox "No names found in column A.", vbInformation
        Exit Sub
    End If
    
    ' Resize output array to hold all rows: (3 rows per name + 1 empty row) * number of names
    ' Subtract 1 empty row at the end since we don't need it after the last name
    ReDim outputArray(1 To (uniqueNames.Count * 4) - 1, 1 To 1)
    outputRow = 1
    
    ' Populate the output array
    For collIndex = 1 To uniqueNames.Count
        ' Add 3 rows with the name
        outputArray(outputRow, 1) = uniqueNames(collIndex)
        outputArray(outputRow + 1, 1) = uniqueNames(collIndex)
        outputArray(outputRow + 2, 1) = uniqueNames(collIndex)
        
        ' Add an empty row (skip for the last name)
        If collIndex < uniqueNames.Count Then
            outputArray(outputRow + 3, 1) = ""
        End If
        
        ' Move to the next block of rows
        outputRow = outputRow + 4
    Next collIndex
    
    ' Write the entire array to the output sheet in one go (super fast!)
    ' Starting at row 8, column 2 (matches your original code's starting point)
    wsOutput.Cells(8, 2).Resize(UBound(outputArray, 1), UBound(outputArray, 2)).Value = outputArray
    
    MsgBox "Unique names processed successfully!", vbInformation
End Sub

Key Improvements Explained #

1. Fixed Collection Usage #

Now we add the name as both the Item and Key:

uniqueNames.Add Item:=Trim(nameParts(j)), Key:=Trim(nameParts(j))

• The Key ensures we don't add duplicate names (since Collection keys must be unique).
• When we call uniqueNames(collIndex), we get the actual name (the Item), not a count.

2. Massive Efficiency Boost #

• Array-Based Output: We build all our output in a VBA array first, then write it to the sheet in a single operation. This eliminates dozens/hundreds of individual cell writes, which is the #1 way to speed up VBA macros.
• Reliable Last Row Check: wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row correctly finds the last used row in column A, even if there are empty cells in between.
• Minimal Worksheet Interactions: We only read from the source sheet once per row, and write to the output sheet once total.

3. Better Error Handling #

• We check if the required worksheets exist before proceeding.
• We only use On Error Resume Next when adding to the Collection (to catch duplicate keys), so other errors (like missing ranges) will still trigger a meaningful message instead of being hidden.

4. Cleaned Up Logic #

• We skip empty cells in the source column to avoid processing junk.
• We trim names to handle any accidental spaces (e.g., " John Doe " becomes "John Doe").
• We avoid the unnecessary ClearContents call since we're not using a temporary range anymore.

Give this macro a try—you should see a huge speed improvement, and it'll output the names correctly in your desired format!

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