如何生成无重复的水果统计字符串？VBA代码问题求助

你的代码生成的字符串出现重复水果，核心原因是没有标记已处理的水果：外层循环会重复遍历到已经被统计过的重复项，导致多次将同一水果写入结果数组，最终输出重复内容。

方案一：修改原代码逻辑，加入标记机制 #

通过新增标记数组记录已处理的水果位置，避免重复统计：

Dim y As Integer    
Dim Counter1 As Integer
Dim Counter2 As Integer
Dim NewBufferCounter As Integer
Dim a As Integer
Dim ArrayBuffer1(15) As String
Dim NewBuffer(15) As String
Dim FinalString(15) As String
Dim isProcessed(15) As Boolean ' 新增：标记水果是否已被处理
Counter1 = 0
Counter2 = 0
a = 1
NewBufferCounter = 0

' 初始化标记数组
For Counter1 = 0 To UBound(isProcessed)
    isProcessed(Counter1) = False
Next Counter1

Counter1 = 0
' 嵌套循环统计重复项
For Counter1 = 0 To (y - 1)
    If isProcessed(Counter1) Then ' 跳过已处理的水果
        GoTo NextCounter1
    End If
    a = 1
                                     
    For Counter2 = Counter1 + 1 To (y - 1)
        If ArrayBuffer1(Counter1) = ArrayBuffer1(Counter2) And ArrayBuffer1(Counter1) <> "" Then
            a = a + 1
            isProcessed(Counter2) = True ' 标记后续重复项为已处理
        End If
    Next Counter2
    
    ' 统计完成后统一写入结果数组
    If a > 1 Then
        NewBuffer(NewBufferCounter) = ArrayBuffer1(Counter1) & " x" & a
    Else
        NewBuffer(NewBufferCounter) = ArrayBuffer1(Counter1)
    End If
    NewBufferCounter = NewBufferCounter + 1
NextCounter1:
Next Counter1

' 处理仅1行数据的情况
If y = 1 Then
    NewBuffer(NewBufferCounter) = ArrayBuffer1(0)
    NewBufferCounter = NewBufferCounter + 1
End If

AmountDiffFruits = NewBufferCounter - 1 ' 修正计数，避免多循环一次

' 生成最终字符串
FinalString(0) = ""
For NewBufferCounter = 0 To AmountDiffFruits
    If NewBuffer(NewBufferCounter) <> "" Then
        If FinalString(0) = "" Then
            FinalString(0) = NewBuffer(NewBufferCounter)
        Else
            FinalString(0) = FinalString(0) & " + " & NewBuffer(NewBufferCounter)
        End If
    End If
Next NewBufferCounter
                                    
Erase ArrayBuffer1()
Erase NewBuffer()
Erase FinalString()
Erase isProcessed()
NewBufferCounter = 0

方案二：使用Dictionary简化逻辑（更推荐） #

利用VBA的Dictionary对象自动去重并统计次数，代码更简洁不易出错：

Dim y As Integer
Dim ArrayBuffer1(15) As String
Dim fruitDict As Object
Dim key As Variant
Dim finalStr As String

Set fruitDict = CreateObject("Scripting.Dictionary")

' 遍历数组统计水果出现次数
For Counter1 = 0 To y - 1
    If ArrayBuffer1(Counter1) <> "" Then
        If fruitDict.Exists(ArrayBuffer1(Counter1)) Then
            fruitDict(ArrayBuffer1(Counter1)) = fruitDict(ArrayBuffer1(Counter1)) + 1
        Else
            fruitDict(ArrayBuffer1(Counter1)) = 1
        End If
    End If
Next Counter1

' 生成目标格式字符串
finalStr = ""
For Each key In fruitDict.Keys
    If fruitDict(key) > 1 Then
        finalStr = IIf(finalStr = "", "", finalStr & " + ") & key & " x" & fruitDict(key)
    Else
        finalStr = IIf(finalStr = "", "", finalStr & " + ") & key
    End If
Next key

' 可根据需求输出结果，例如：MsgBox finalStr

Set fruitDict = Nothing
Erase ArrayBuffer1()

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