如何修改Excel VBA代码，循环列表并拼接含多位数数量的唯一/重复ID

需求 #

修改原Excel VBA代码，实现提取A列中对应前缀的数量值（支持1-4位不等的数量格式），并将同一前缀的唯一数量合并到B列中。

示例效果 #

尝试的原始代码 #

Sub test2()

Dim rg As Range, cell As Range, c As Range, d As Range
Dim arr, fa As String 

With Sheets("Sheet2")
Set rg = .Range("A2", .Range("A" & Rows.Count).End(xlUp))
End With

Set arr = CreateObject("scripting.dictionary")

For Each cell In rg: arr.Item(Left(cell.Value, 4)) = 1: Next 
    For Each el In arr
    Set c = Columns(1).Find(el, lookat:=xlPart, after:=Cells(1, 1))
    'Debug.Print c.Address
    fa = c.Address

    'Debug.Print "fa: " & fa
    Set d = c.Offset(0, 1): d.Value = Right(c.Value, 4)

        Do
            Set c = Columns(1).Find(el, lookat:=xlPart, after:=c)
            If d.Find(Right(c.Value, 3), lookat:=xlPart) Is Nothing _
            Then d.Value = d.Value & ", " & Right(c.Value, 4)  
        Loop Until c.Address = fa 
    Next   
    Range("B1").Value = "RESULT"
   
End Sub

修改后的代码（适配多位数数量） #

Sub ExtractQuantities()
    Dim rg As Range, cell As Range
    Dim dict As Object
    Dim key As String, quantity As String
    Dim ws As Worksheet
    
    ' 指定目标工作表
    Set ws = ThisWorkbook.Sheets("Sheet2")
    ' 定义A列数据范围（从A2到最后一行非空单元格）
    Set rg = ws.Range("A2", ws.Range("A" & ws.Rows.Count).End(xlUp))
    ' 创建字典存储每个前缀对应的唯一数量集合
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 遍历所有单元格，收集唯一数量
    For Each cell In rg
        If cell.Value <> "" Then
            ' 提取前4位作为分组键
            key = Left(cell.Value, 4)
            ' 提取前4位之后的所有内容作为数量（适配1-4位数字）
            quantity = Mid(cell.Value, 5)
            
            ' 初始化或更新字典中的数量集合
            If Not dict.Exists(key) Then
                dict(key) = Array(quantity)
            Else
                ' 避免添加重复数量
                If IsError(Application.Match(quantity, dict(key), 0)) Then
                    dict(key) = dict(key) & Array(quantity)
                End If
            End If
        End If
    Next cell
    
    ' 将结果写入B列对应位置
    For Each key In dict.Keys
        Set cell = rg.Find(What:=key, LookIn:=xlValues, LookAt:=xlPart)
        If Not cell Is Nothing Then
            ' 用逗号连接数量集合
            cell.Offset(0, 1).Value = Join(dict(key), ", ")
        End If
    Next key
    
    ' 设置B列标题
    ws.Range("B1").Value = "RESULT"
End Sub

关键修改说明 #

1. 数量提取逻辑：替换原代码中固定取后4位的Right(cell.Value,4)为Mid(cell.Value,5)，确保完整提取前4位前缀后的所有数字（无论1-4位）。
2. 去重效率：改用字典存储每个前缀对应的数量数组，直接通过Match函数判断数量是否已存在，避免原代码中循环查找的低效和误差。
3. 代码健壮性：明确指定工作表对象，增加空单元格判断，避免跨工作表操作出错。
4. 结果合并：使用Join函数直接合并数量数组，简化代码逻辑。

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