重新编号-按指定起始号及编码列

zllyyz

请大大们相助，谢谢。

yynrzwh

按指定起始号及编码 重新编号.zip (21.78 KB, 下载次数: 5)

2024-3-9 21:20 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, br, i&, dic As Object, iStart&
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
    If Range("AA2").Value = "" Then iStart = 0 Else iStart = Range("AA2").Value - 1
   
    ar = Range("B1", Cells(Rows.Count, "B").End(xlUp)).Value
    ReDim br(1 To UBound(ar), 0) As String: br(1, 0) = "编号"
    For i = 2 To UBound(ar)
        If Len(ar(i, 1)) Then
            If Not dic.exists(ar(i, 1)) Then
                iStart = iStart + 1
                dic(ar(i, 1)) = Format(iStart, "0000")
            End If
            br(i, 0) = dic(ar(i, 1))
        End If
    Next i
   
    [AC1].Resize(UBound(br)) = br
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

cnmlgb9998

PQ 达成你要求的第二项！！！！