Sub Macro1()
Dim d As Object, d1 As Object, arr, i As Long, k As Long, r1 As Long
xlapp.ScreenUpdating = False
r1 = xlapp.Cells(xlapp.Rows.Count, 6).End(xlUp).Row
arr = xlapp.Range("e" & 行 & ":f" & r1)
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
a = Left(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 4)
b = Mid(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 5, 5)
For i = 1 To UBound(arr)
s = arr(i, 2)
If Not d.Exists(s) Then k = k + 1: d1(s) = b + k
d(s) = d(s) + 1
arr(i, 1) = a & Format(d1(s), "00000") & d(s)
Next
For i = 1 To UBound(arr)
s = arr(i, 2)
If d(s) = 1 Then Mid(arr(i, 1), Len(arr(i, 1)), 1) = "0"
Next
xlapp.Range("e" & 行 & ":f" & r1) = arr
xlapp.ScreenUpdating = True
End Sub
Dim d As Object, d1 As Object, arr, i As Long, k As Long, r1 As Long
xlapp.ScreenUpdating = False
r1 = xlapp.Cells(xlapp.Rows.Count, 6).End(xlUp).Row
arr = xlapp.Range("e" & 行 & ":f" & r1)
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
a = Left(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 4)
b = Mid(xlapp.Range("e" & xlapp.Rows.Count).End(xlUp), 5, 5)
For i = 1 To UBound(arr)
s = arr(i, 2)
If Not d.Exists(s) Then k = k + 1: d1(s) = b + k
d(s) = d(s) + 1
arr(i, 1) = a & Format(d1(s), "00000") & d(s)
Next
For i = 1 To UBound(arr)
s = arr(i, 2)
If d(s) = 1 Then Mid(arr(i, 1), Len(arr(i, 1)), 1) = "0"
Next
xlapp.Range("e" & 行 & ":f" & r1) = arr
xlapp.ScreenUpdating = True
End Sub