Sub test()
Dim myArea As Range, a, b, i As Long, ii As Long
Dim n As Long, ub As Long, x, dic As Object
Set dic = CreateObject("Scripting.Dictionary")
a = Sheets("data").[h1].CurrentRegion.Value
For i = 1 To UBound(a, 1)
dic(a(i, 1)) = Format$(a(i, 2), String(12, "0"))
Next
With Sheets("main")
ub = .Columns(1).SpecialCells(2, 1).Areas(1).CurrentRegion.Columns.Count - 1
ReDim a(1 To .Columns(1).SpecialCells(2, 1).Count, 1 To ub + 1)
For Each myArea In .Columns(1).SpecialCells(2, 1).Areas
With myArea.Offset(, 1).Resize(, ub + 1)
b = .Value
For i = 1 To UBound(b, 1)
n = n + 1
For ii = 1 To ub
a(n, ii) = b(i, ii)
Next
x = GetSortVal(a(n, 1))
If dic.exists(a(n, 2)) Then
a(n, ub + 1) = dic(a(n, 2)) & " " & x
Else
a(n, 7) = "zzz " & x
End If
Next
End With
Next
VSortM a, 1, n, 7
x = 1
For Each myArea In .Columns(1).SpecialCells(2, 1).Areas
n = myArea.Count
myArea.Offset(, 1).Resize(n, ub).Value = Application.Index(a, Evaluate("row(" & x & ":" & _
x + n - 1 & ")"), Evaluate("column(" & [a1].Resize(, ub).Address & ")"))
x = x + n
Next
End With
End Sub
Function GetSortVal(ByVal txt As String) As String
Dim i As Long, m As Object
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "\d+"
If .test(txt) Then
For i = .Execute(txt).Count - 1 To 0 Step -1
Set m = .Execute(txt)(i)
txt = Application.Replace(txt, m.firstindex + 1, m.Length, Format$(m.Value, String(12, "0")))
Next
End If
End With
GetSortVal = txt
End Function
Private Sub VSortM(ary, LB, ub, ref)
Dim i As Long, ii As Long, iii As Long, m, temp
i = ub: ii = LB
m = ary(Int((LB + ub) / 2), ref)
Do While ii <= i
Do While ary(ii, ref) < m: ii = ii + 1: Loop
Do While ary(i, ref) > m: i = i - 1: Loop
If ii <= i Then
For iii = LBound(ary, 2) To UBound(ary, 2)
temp = ary(ii, iii): ary(ii, iii) = ary(i, iii): ary(i, iii) = temp
Next
i = i - 1: ii = ii + 1
End If
Loop
If LB < i Then VSortM ary, LB, i, ref
If ii < ub Then VSortM ary, ii, ub, ref
End Sub
