增加合并相同项功能

 Sub CombineNamesByID_FixedHeaders()
    Dim selectedRange As Range
    Dim delimiter As String
    Dim outputCell As Range
    Dim dict As Object
    Dim dataArr As Variant
    Dim id As Variant, name As Variant
    Dim lastCol As Long
    Dim count As Long
    Dim i As Long
    Dim hasHeader As Boolean
    
    ' 检查是否选中了区域
    On Error Resume Next
    Set selectedRange = Application.Selection
    On Error GoTo 0
    
    If selectedRange Is Nothing Then
        MsgBox "请先选择包含编号和名称的两列数据区域", vbExclamation
        Exit Sub
    End If
    
    ' 检查选中区域是否为两列
    If selectedRange.Columns.Count <> 2 Then
        MsgBox "请选择正好两列的数据区域（编号和名称）", vbExclamation
        Exit Sub
    End If
    
    ' 询问用户是否选中区域包含标题行
    hasHeader = (MsgBox("选中的区域是否包含标题行（如“编号”“名称”）？", vbQuestion + vbYesNo, "标题行检查") = vbYes)
    
    ' 获取分隔符
    delimiter = InputBox("请输入要使用的分隔符（默认为//）", "分隔符", "//")
    If delimiter = "" Then delimiter = "//"
    
    ' 确定输出位置（默认为工作表最右侧的第一个空列）
    lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    If lastCol < 1 Then lastCol = 1
    
    Set outputCell = Application.InputBox( _
        "请选择结果放置的起始单元格", _
        "输出位置", _
        Cells(1, lastCol + 1).Address, _
        Type:=8)
    
    If outputCell Is Nothing Then Exit Sub
    
    ' 创建字典来存储合并结果
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' 将选中区域数据读入数组
    dataArr = selectedRange.Value
    
    ' 处理数据（如果包含标题行，则从第2行开始）
    Dim startRow As Long
    startRow = IIf(hasHeader, 2, 1)
    
    count = 0
    For i = startRow To UBound(dataArr, 1)
        If Not IsEmpty(dataArr(i, 1)) And Not IsEmpty(dataArr(i, 2)) Then
            id = CStr(dataArr(i, 1))
            name = CStr(dataArr(i, 2))
            
            If dict.exists(id) Then
                dict(id) = dict(id) & delimiter & name
            Else
                dict.Add id, name
            End If
            
            count = count + 1
        End If
    Next i
    
    ' 准备输出数组
    Dim outputArr() As Variant
    ReDim outputArr(1 To dict.Count + 1, 1 To 2)
    
    ' 填充表头（如果原数据没有标题行，则添加）
    If Not hasHeader Then
        outputArr(1, 1) = "编号"
        outputArr(1, 2) = "名称"
    End If
    
    ' 填充数据
    i = IIf(hasHeader, 1, 2)  ' 如果已有标题行，则从第1行开始填充数据
    For Each id In dict.keys
        outputArr(i, 1) = id
        outputArr(i, 2) = dict(id)
        i = i + 1
    Next id
    
    ' 一次性写入结果
    outputCell.Resize(UBound(outputArr, 1), 2).Value = outputArr
    
    ' 自动调整列宽
    outputCell.EntireColumn.AutoFit
    outputCell.Offset(0, 1).EntireColumn.AutoFit
    
    ' 显示统计信息
    MsgBox "处理完成！" & vbCrLf & _
           "处理了 " & count & " 行数据" & vbCrLf & _
           "生成了 " & dict.Count & " 个唯一编号", _
           vbInformation, "完成"
End Sub

感谢大佬!完美解决!