求助：VBA实现连续重复文本值追加对应序号的问题

问题场景 #

需要对一列文本值进行处理：连续出现的相同值追加递增序号，非连续的重复值重新从1开始计数。现有VBA代码无法正确实现该逻辑，输出结果不符合预期。

示例对照 #

• 输入数据：

  原数据
  A
  A
  B
  A
  A
  A
  C
  B

• 期望输出：

  处理后数据
  A-1
  A-2
  B-1
  A-1
  A-2
  A-3
  C-1
  B-1

• 当前代码输出问题：连续重复值的序号未正确递增，部分条目计数错误。

当前使用的VBA代码 #

Sub groupindexcells()
    Dim arr As Variant
    Dim rlast As Long, i As Long, rsum As Long
    Dim comparevalue

    rlast = Sheet1.Cells(Rows.count, "A").End(xlUp).Row
    arr = Sheet1.Range("A2:A" & rlast).Value
    rsum = 1
    
    For i = 1 To UBound(arr) - 1
        If comparevalue = "" Then
            If arr(i, 1) = arr(i + 1, 1) Then
                arr(i, 1) = arr(i, 1) & "-" & rsum
                rsum = rsum + 1
            Else
                arr(i, 1) = arr(i, 1) & "-" & rsum
                comparevalue = arr(i + 1, 1)
                rsum = 1
            End If
        Else
            If arr(i, 1) = comparevalue Then
                If arr(i, 1) = arr(i + 1, 1) Then
                    arr(i, 1) = arr(i, 1) & "-" & rsum
                    rsum = rsum + 1
                Else
                    comparevalue = arr(i + 1, 1)
                    arr(i, 1) = arr(i, 1) & "-" & rsum
                    rsum = 1
                End If
            End If
        End If
    Next i
    
    'append the index for the last row
    If arr(UBound(arr), 1) = comparevalue Then
        arr(UBound(arr), 1) = arr(UBound(arr), 1) & "-" & rsum
    Else
        arr(UBound(arr), 1) = arr(UBound(arr), 1) & "-" & 1
    End If

    Sheet1.Range("A2:A" & rlast).Value = arr
End Sub

问题分析 #

原代码逻辑过于复杂，comparevalue的初始化和判断存在漏洞：

1. 未正确跟踪当前连续组的起始值，导致第一个元素的计数逻辑混乱
2. 嵌套条件判断过多，容易出现分支遗漏，导致部分条目未正确计数
3. 最后一行的处理依赖comparevalue的状态，容易出现判断错误

修正后的VBA代码 #

Sub AddConsecutiveIndex()
    Dim arr As Variant
    Dim rLast As Long, i As Long
    Dim currentCount As Long
    Dim prevValue As String
    
    ' 获取数据范围最后一行
    rLast = Sheet1.Cells(Rows.Count, "A").End(xlUp).Row
    ' 将数据读入数组（从A2开始）
    arr = Sheet1.Range("A2:A" & rLast).Value
    
    ' 处理空数组情况
    If UBound(arr) < 1 Then Exit Sub
    
    ' 初始化计数器和上一个值
    currentCount = 1
    prevValue = arr(1, 1)
    ' 给第一个元素追加序号
    arr(1, 1) = arr(1, 1) & "-" & currentCount
    
    ' 从第二个元素开始遍历
    For i = 2 To UBound(arr)
        ' 当前值和上一个值相同，计数器递增
        If arr(i, 1) = prevValue Then
            currentCount = currentCount + 1
        Else
            ' 值不同，重置计数器，更新上一个值
            currentCount = 1
            prevValue = arr(i, 1)
        End If
        ' 追加序号
        arr(i, 1) = arr(i, 1) & "-" & currentCount
    Next i
    
    ' 将处理后的数组写回单元格
    Sheet1.Range("A2:A" & rLast).Value = arr
End Sub

代码逻辑说明 #

1. 数据读取：将目标列数据读入数组，提升处理效率
2. 初始化：设置初始计数器为1，记录第一个元素的值并追加序号
3. 遍历处理：从第二个元素开始，对比当前值与上一个值：
   • 相同则计数器+1，不同则重置为1并更新上一个值
   • 为每个元素追加对应的序号
4. 写回数据：将处理后的数组批量写回原单元格

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