VBA宏优化需求：循环单元格范围累加多重复项对应金额

Hey Patrick, let's get this VBA macro fixed to handle all duplicate Bilagsnr. entries properly—no more one-off accumulations or messy loops! Your original code was on the right track, but it only targets the first duplicate it finds and uses inefficient cell-by-cell lookups. Here's a streamlined approach using a Scripting.Dictionary to handle all duplicates in a single pass:

Optimized Code #

Sub AccumulateDuplicateBilagsnr()
    Dim sht As Worksheet
    Dim bilagCol As Long, amountCol As Long
    Dim lastRow As Long
    Dim dict As Object
    Dim currentBilag As Variant, currentAmount As Double
    Dim i As Long
    
    ' Set your target worksheet (update to match your sheet name)
    Set sht = ThisWorkbook.Worksheets("Sheet1")
    ' Use late-binding for the dictionary (no need to add references)
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Locate the column for "Bilagsnr." and your amount column
    bilagCol = sht.Rows(1).Find(What:="Bilagsnr.", LookIn:=xlValues, LookAt:=xlWhole).Column
    ' Assuming amount is the column immediately right of Bilagsnr.
    ' If your amount has a specific header (e.g., "Amount"), replace this with a Find call:
    ' amountCol = sht.Rows(1).Find(What:="Amount", LookIn:=xlValues, LookAt:=xlWhole).Column
    amountCol = bilagCol + 1
    
    ' Get the last row with data in the Bilagsnr. column
    lastRow = sht.Cells(sht.Rows.Count, bilagCol).End(xlUp).Row
    
    ' Loop from bottom to top (avoids row-shifting issues if deleting duplicates)
    For i = lastRow To 2 Step -1
        currentBilag = sht.Cells(i, bilagCol).Value
        currentAmount = sht.Cells(i, amountCol).Value
        
        ' Skip blank Bilagsnr. entries if needed
        If Not IsEmpty(currentBilag) Then
            If dict.Exists(currentBilag) Then
                ' Add the current amount to the first occurrence's amount
                sht.Cells(dict(currentBilag), amountCol).Value = _
                    sht.Cells(dict(currentBilag), amountCol).Value + currentAmount
                
                ' Optional: Delete the duplicate row (remove comment if you don't need to keep duplicates)
                ' sht.Rows(i).Delete
            Else
                ' Store the first occurrence's row number in the dictionary
                dict.Add Key:=currentBilag, Item:=i
            End If
        End If
    Next i
    
    MsgBox "All duplicate Bilagsnr. amounts have been accumulated!", vbInformation
End Sub

Key Improvements Over Your Original Code #

• Single Pass Processing: Instead of looping through each cell and running repeated CountIfs/Find calls (which are slow for large datasets), we traverse the data once.
• Dictionary Lookups: The Scripting.Dictionary lets us instantly check if a Bilagsnr. has been seen before, and stores the row number of its first occurrence. This makes duplicate checks near-instant.
• Handles All Duplicates: Every duplicate entry's amount gets added to the first occurrence—no more missing subsequent duplicates.
• Optional Row Deletion: We loop from bottom to top so if you choose to delete duplicate rows, the row numbers don't shift and break the loop.

Important Notes #

• Update ThisWorkbook.Worksheets("Sheet1") to match your actual worksheet name.
• If your amount column isn't directly right of Bilagsnr., replace the amountCol = bilagCol + 1 line with a Find call targeting your amount header (example commented in the code).
• The code skips blank Bilagsnr. entries—remove that check if you need to handle blanks as duplicates.
• Ensure your amount column contains numeric values (not text) to avoid calculation errors.

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