Excel VBA技术问题：识别A列重复项并按规则重新排列

需求说明 #

识别Excel工作表Table2中A列的重复项，将相同重复值归类到同一列：

• 从B列左侧开始插入列存放重复值
• 若发现新的唯一重复值，需回到B列左侧的首个可用列作为插入点

原代码问题 #

当前宏执行后，每次检测到重复项（即使是新的唯一值）都会新建列并向左偏移，不符合归类需求。

原VBA代码 #

Sub testworking()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Table2")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    Dim i As Long
    Dim value As Variant
    Dim colIndex As Long

    Dim colDict As Object
    Set colDict = CreateObject("Scripting.Dictionary")

    For i = 1 To lastRow
        value = ws.Cells(i, 1).value
        If dict.Exists(value) Then
            colIndex = colDict(value) - 1 ' Adjust to insert left to B
            If colIndex < 2 Then ' Ensure we do not go beyond column A
                colIndex = 2
            End If
            ws.Columns(colIndex).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            ws.Cells(i, colIndex).value = value
        Else
            dict.Add value, 1
            colDict.Add value, ws.Cells(i, 1).Column ' Store the initial column index
        End If
    Next i

End Sub

问题根源 #

1. colDict错误存储了值的初始列（A列，索引1），导致重复时计算出的插入列逻辑混乱
2. 循环中实时插入列会动态改变后续列的索引，导致后续值的列定位错误
3. 未正确跟踪每个唯一值对应的目标列，新唯一值的处理逻辑缺失

修正后的代码 #

Sub ClassifyDuplicates()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Table2")
    
    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' 第一步：收集所有唯一值并分配目标列
    Dim valueDict As Object
    Set valueDict = CreateObject("Scripting.Dictionary")
    Dim targetCol As Long
    targetCol = 2 ' 从B列开始
    
    Dim i As Long
    Dim cellValue As Variant
    For i = 1 To lastRow
        cellValue = ws.Cells(i, 1).Value
        If Not valueDict.Exists(cellValue) Then
            valueDict.Add cellValue, targetCol
            targetCol = targetCol + 1
        End If
    Next i
    
    ' 第二步：一次性插入需要的列（避免实时插入导致索引混乱）
    If targetCol > 2 Then
        ws.Columns("B").Resize(, targetCol - 2).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    End If
    
    ' 第三步：填充重复值到对应列
    For i = 1 To lastRow
        cellValue = ws.Cells(i, 1).Value
        ' 跳过首次出现的值（保留在A列）
        If WorksheetFunction.CountIf(ws.Range("A1:A" & i), cellValue) > 1 Then
            ws.Cells(i, valueDict(cellValue)).Value = cellValue
        End If
    Next i
End Sub

代码说明 #

1. 先遍历A列收集所有唯一值，为每个值分配从B列开始的目标列号
2. 根据唯一值数量一次性插入所需列，避免循环中插入列导致的索引偏移
3. 再次遍历A列，将重复出现的值填充到对应的目标列，首次出现的值保留在A列

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