Sub SortMultiCols()
Dim SortRng As Range, Col(), i As Long, j As Long, k As Long, x, z, t
Dim rws As Long, cls As Long
Dim reg As Object
Set reg = CreateObject("VbScript.RegExp")
reg.Global = True
reg.Pattern = "\d+$"
Col = Array(6, 8, 2)
rws = [A65536].End(3).Row
cls = 2
For j = LBound(Col) To UBound(Col)
ReDim t(5 To rws, 1 To 1)
For i = 5 To rws
If Cells(i, Col(j) + cls).Value <> "" Then
If reg.test(Cells(i, Col(j) + cls).Value) Then
If k < Len(reg.Execute(Cells(i, Col(j) + cls).Value)(0)) Then
k = Len(reg.Execute(Cells(i, Col(j) + cls).Value)(0))
End If
t(i, 1) = Len(reg.Execute(Cells(i, Col(j) + cls).Value)(0))
Else
t(i, 1) = 0
End If
Else
t(i, 1) = 0
End If
Next i
For i = 5 To rws
If t(i, 1) > 0 Then
x = Right(10 ^ k + CLng(Right(Cells(i, Col(j) + cls).Value, t(i, 1))), k)
z = Left(Cells(i, Col(j) + cls).Value, Len(Cells(i, Col(j) + cls).Value) - t(i, 1)) & x
Cells(i, Col(j) + cls).Value = z
End If
Next i
Next
Set SortRng = Range("B4", [B65536].End(3))
ActiveSheet.Sort.SortFields.Clear
With Worksheets("Sheet1").Sort
For j = LBound(Col) To UBound(Col)
.SortFields.Add SortRng.Offset(, Col(j))
Next
.SetRange SortRng.Resize(, 150)
.Header = xlYes
.SortMethod = xlPinYin
.Apply
End With
End Sub
