如何用Excel VBA遍历ID列表并处理唯一值与重复值的字符拼接

以下是实现需求的VBA代码，通过字典按ID前4位分组，完成唯一ID字符输出、重复ID字符拼接的功能：

Sub ProcessIDCharacters()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim idDict As Object
    Dim i As Long
    Dim idStr As String
    Dim keyPrefix As String
    Dim targetChar As String
    Dim dictItem As Variant
    
    ' 指定要处理的工作表，根据实际修改名称
    Set ws = ThisWorkbook.Sheets("Sheet1")
    ' 获取A列最后一行数据行号
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    ' 创建字典用于分组记录前4位相同的ID
    Set idDict = CreateObject("Scripting.Dictionary")
    
    ' 遍历A列ID
    For i = 2 To lastRow
        idStr = Trim(ws.Cells(i, "A").Value)
        ' 跳过空单元格
        If idStr <> "" Then
            ' 提取ID前4位作为分组键
            keyPrefix = Left(idStr, 4)
            
            ' 确定要提取的字符：长度≥5取第5位，否则取最后一位
            If Len(idStr) >= 5 Then
                targetChar = Mid(idStr, 5, 1)
            Else
                targetChar = Right(idStr, 1)
            End If
            
            ' 字典中无此分组时，记录首次出现的行号和字符
            If Not idDict.Exists(keyPrefix) Then
                idDict.Add keyPrefix, Array(i, targetChar)
            Else
                ' 已有分组时，追加字符到拼接字符串
                dictItem = idDict(keyPrefix)
                idDict(keyPrefix) = Array(dictItem(0), dictItem(1) & targetChar)
            End If
        End If
    Next i
    
    ' 将结果写入B列
    For Each keyPrefix In idDict.Keys
        dictItem = idDict(keyPrefix)
        ' 唯一ID或重复ID组的第一个单元格写入结果
        ws.Cells(dictItem(0), "B").Value = dictItem(1)
        ' 可选：若需要清空重复ID后续行的B列内容，可添加循环处理
    Next keyPrefix
    
    ' 释放对象
    Set idDict = Nothing
    Set ws = Nothing
End Sub

代码说明： #

• 工作表适配：将Sheet1修改为你实际需要处理的工作表名称
• 字符提取逻辑：自动判断ID长度，长度≥5时取第5位字符，不足5位则取最后一位
• 重复项处理：通过字典按ID前4位分组，同组的目标字符会被拼接，最终写入该组第一个ID对应的B列单元格
• 空值过滤：自动跳过A列的空单元格，避免运行错误

使用步骤： #

1. 打开目标Excel文件，按Alt + F11打开VBA编辑器
2. 右键点击左侧工程窗口，选择「插入」→「模块」
3. 将上述代码粘贴到模块中
4. 按需修改工作表名称，按F5运行代码

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