本帖最后由 一把小刀闯天下 于 2020-3-18 09:20 编辑
Option Explicit
Sub test()
Dim i, arr, s, t, p
arr = Range("a1:c" & Cells(Rows.Count, "a").End(xlUp).Row + 1).Value
Call qsort(arr, 1, UBound(arr, 1) - 1, 1, 2, 1)
For i = 1 To UBound(arr, 1) - 1
t = Split(arr(i, 2), "*")
If UBound(t) > 0 Then s = Format(t(1), String(6, "0")) Else s = String(6, "0")
arr(i, 3) = left(t(0), 1) & Format(Mid(t(0), 2), String(6, "0")) & s
If arr(i, 1) <> arr(i + 1, 1) Then
Call qsort(arr, p + 1, i, 1, UBound(arr, 2), 3)
p = i
End If
Next
[e1].Resize(UBound(arr, 1) - 1, 2) = arr
End Sub
Function qsort(arr, first, last, left, right, key)
Dim i As Long, j As Long, k As Long, x As String, t As String
i = first: j = last: x = arr((first + last) / 2, key)
While i <= j
While StrComp(arr(i, key), x, vbTextCompare) = -1: i = i + 1: Wend
While StrComp(x, arr(j, key), vbTextCompare) = -1: j = j - 1: Wend
If i <= j Then
For k = left To right
t = arr(i, k): arr(i, k) = arr(j, k): arr(j, k) = t
Next
i = i + 1: j = j - 1
End If
Wend
If first < j Then qsort arr, first, j, left, right, key
If i < last Then qsort arr, i, last, left, right, key
End Function
|