AW: VBA Lösung aufgebohrt
17.07.2015 11:18:46
Rudi
Hallo,
beliebig iele Spalten daneben:
Sub Sortieren()
Dim vntSortArray As Variant
Dim vntArray As Variant
Dim arr1 As Variant
Dim ws As Worksheet
Set ws = ActiveSheet
With Cells(1, 1).CurrentRegion
arr1 = .Offset(1).Resize(.Rows.Count - 1)
End With
vntArray = InhaltSplitten(arr1, 1)
vntSortArray = Array(UBound(vntArray, 2) - 1, UBound(vntArray, 2))
Call prcSort(vntSortArray, vntArray)
Sheets.Add
ws.Cells(1, 1).Resize(, UBound(arr1, 2)).Copy Cells(1, 1)
Cells(2, 1).Resize(UBound(arr1, 1), UBound(arr1, 2)) = vntArray
End Sub
Function InhaltSplitten(arr As Variant, SplitSpalte As Long) As Variant
Dim arrSplit() As Variant
Dim i As Long
Dim j As Long
Dim k As Long
ReDim arrSplit(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 2)
For i = LBound(arr) To UBound(arr)
For j = 1 To Len(arr(i, SplitSpalte))
If Not IsNumeric(Mid(arr(i, SplitSpalte), j, 1)) Then
For k = 1 To UBound(arr, 2)
arrSplit(i, k) = arr(i, k)
Next k
If j = 1 Then
arrSplit(i, k) = ""
Else
arrSplit(i, k) = CLng(Left(arr(i, 1), j - 1))
End If
arrSplit(i, k + 1) = Right(arr(i, 1), Len(arr(i, 1)) - j + 1)
Exit For
End If
If j = Len(arr(i, SplitSpalte)) Then
For k = 1 To UBound(arr, 2)
arrSplit(i, k) = arr(i, k)
Next
arrSplit(i, k) = CLng(arr(i, 1))
End If
Next j
Next i
InhaltSplitten = arrSplit
End Function
Gruß
Rudi