VBA Code für Excel-Sortierung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub aaa() Dim arr(), rngC As Range, lMax As Integer, i As Integer For Each rngC In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)) lMax = WorksheetFunction.Max(lMax, Len(rngC)) Next ReDim arr(1 To WorksheetFunction.CountA(Columns(1)), 1 To lMax + 1) For Each rngC In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)) arr(rngC.Row, Len(rngC)) = rngC.Offset(, 1) arr(rngC.Row, UBound(arr, 2)) = rngC Next With Sheets(2) .Cells.ClearContents .Cells(2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr .Cells(1, UBound(arr, 2)) = "Kennung" For i = 1 To lMax .Cells(1, i) = i On Error Resume Next With .Range(.Cells(1, i).End(xlDown), _ .Cells(UBound(arr) + 1, 1)).SpecialCells(xlCellTypeBlanks) .FormulaR1C1 = "=R[-1]C" .Value = .Value End With On Error GoTo 0 Next End With End Sub

Hallo,
so?

Sub aaa()
Dim arr(), rngC As Range, lMax As Integer, i As Integer
For Each rngC In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
lMax = WorksheetFunction.Max(lMax, Len(rngC))
Next
ReDim arr(1 To WorksheetFunction.CountA(Columns(1)), 1 To lMax + 1)
For Each rngC In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
arr(rngC.Row, Len(rngC)) = rngC.Offset(, 1)
arr(rngC.Row, UBound(arr, 2)) = rngC
Next
With Sheets(2)
.Cells.ClearContents
.Cells(2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
.Cells(1, UBound(arr, 2)) = "Kennung"
For i = 1 To lMax
.Cells(1, i) = i
On Error Resume Next
With .Range(.Cells(1, i).End(xlDown), _
.Cells(UBound(arr) + 1, i)).SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
End With
On Error GoTo 0
Next
With .Cells(1, 1).CurrentRegion
.Copy
.PasteSpecial xlPasteValues
End With
Application.CutCopyMode = False
End With
End Sub

Gruß
Rudi

Sub aaa() Dim arr(), rngC As Range, lMax As Integer, i As Integer Dim arrTmp() For Each rngC In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)) lMax = WorksheetFunction.Max(lMax, Len(rngC)) Next ReDim arr(1 To WorksheetFunction.CountA(Columns(1)), 1 To lMax + 1) ReDim arrTmp(1 To 1, 1 To lMax) For Each rngC In Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp)) arrTmp(1, Len(rngC)) = rngC For i = Len(rngC) + 1 To lMax arrTmp(1, i) = "" Next For i = 1 To Len(rngC) arr(rngC.Row, i) = arrTmp(1, i) Next arr(rngC.Row, UBound(arr, 2)) = rngC Next With Sheets(2) .Cells.ClearContents .Cells(2, 1).Resize(UBound(arr), UBound(arr, 2)) = arr For i = 1 To lMax .Cells(1, i) = i Next .Cells(1, lMax + 1) = "Kennung" End With End Sub

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread