Option Explicit
Sub test()
Dim temp(1 To 2), a, i As Long, ii As Long, n As Long
With Sheets("Sortieren")
For i = 1 To 2
With .ListObjects(i)
a = .DataBodyRange.Value
ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
For ii = 1 To UBound(a, 1)
If a(ii, 2) = "" Then n = ii - 1: Exit For
a(ii, UBound(a, 2)) = GetSortVal(a(ii, 2) & " " & ii)
Next
VSortM a, 1, n, UBound(a, 2)
.DataBodyRange.Value = a
End With
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, "0000000000"))
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