Option Explicit
Sub Test()
NumericSort Range("A1:A2222")
End Sub
Sub NumericSort(rngSort As Range)
Dim myRegexp
Dim myArr()
Dim myKeyRng As Range
Dim i As Long
Set myRegexp = CreateObject("vbscript.regexp")
myRegexp.Global = True
myRegexp.Pattern = "\D"
myArr = rngSort
For i = LBound(myArr) To UBound(myArr)
myArr(i, 1) = myRegexp.Replace(myArr(i, 1), "")
Next i
Set myRegexp = Nothing
Set myKeyRng = Cells(rngSort.Cells(1).Row, Columns.Count).End(xlToLeft).Offset(, 1)
Set myKeyRng = myKeyRng.Resize(UBound(myArr, 1), UBound(myArr, 2))
myKeyRng.Value = myArr
With ActiveSheet
With .Sort
With .SortFields
.Clear
.Add Key:=Range(myKeyRng.Address), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.SetRange Range(Range(rngSort, myKeyRng).Address)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
myKeyRng.Clear
End Sub