Excel列输入重复序号时自动调整数值并排序的VBA实现求助

以下是修改后的VBA代码，可实现你需要的功能：当D列输入重复正整数时，自动将该数字移至对应有序位置，并将其下方区域数值减1，维持从1开始的有序序列。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim inputVal As Variant
    Dim duplicatePos As Range
    Dim adjustRange As Range
    
    ' 仅处理D列单个单元格的变更
    If Target.Cells.Count > 1 Or Intersect(Target, Me.Range("D:D")) Is Nothing Then Exit Sub
    
    On Error GoTo ResetEvents ' 错误处理，确保事件最终恢复
    Application.EnableEvents = False ' 禁用事件，避免循环触发
    
    inputVal = Target.Value
    ' 仅处理正整数（匹配序列从1开始的要求）
    If Not IsNumeric(inputVal) Or inputVal <= 0 Or inputVal <> Int(inputVal) Then
        GoTo ResetEvents
    End If
    
    ' 在D列数据区域中查找当前值的重复项（排除当前单元格）
    Set duplicatePos = Me.Range("D2:D" & Me.Cells(Me.Rows.Count, "D").End(xlUp).Row) _
        .Find(What:=inputVal, After:=Target, LookIn:=xlValues, LookAt:=xlWhole, _
        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    
    ' 找到重复值时执行调整逻辑
    If Not duplicatePos Is Nothing Then
        ' 定义需要减1的区域：从重复值的下一行到输入单元格的上一行
        Set adjustRange = Me.Range(duplicatePos.Offset(1, 0), Target.Offset(-1, 0))
        
        ' 对目标区域批量减1
        If Not adjustRange Is Nothing Then
            adjustRange.Value = Evaluate(adjustRange.Address & "-1")
        End If
        
        ' 将输入的重复值移动到重复值的下一个位置（对应有序位置）
        Target.Cut duplicatePos.Offset(1, 0)
    End If
    
ResetEvents:
    Application.EnableEvents = True ' 恢复事件触发
    On Error Resume Next
End Sub

代码关键逻辑说明 #

• 触发范围控制：只响应D列单个单元格的修改，避免无关操作触发代码。
• 事件循环避免：修改单元格会再次触发Worksheet_Change，因此先禁用事件，操作完成后必须恢复，防止后续Excel事件失效。
• 输入校验：仅处理正整数，符合“从1开始的有序列表”的场景要求。
• 重复值定位：在D列已有的数据范围内查找重复值，确保定位到已存在的目标数值位置。
• 数值调整：将重复值下方到输入位置上方的所有单元格数值减1，填补序列因重复产生的空缺。
• 重复值移动：将输入的重复值剪切到重复值的下一个位置，保证序列的有序性。

测试你的示例场景 #

假设初始D列数据为1,2,3,4,5,6,7,8,9,10（D2到D11）：

1. 将D9的9修改为5；
2. 代码会找到D5位置的重复5；
3. 调整D6到D8的数值（原6,7,8）减1为5,6,7；
4. 将D9的5剪切到D6位置；
5. 最终D列序列变为1,2,3,4,5,5,6,7,9,10，符合有序维护的要求。

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