AW: Werte in Zellen sortieren
22.12.2010 10:16:54
fcs
Hallo Blackhawk,
für max. 254 verschiedene Begriffe (Excel 2003 und älter) geht es mit dem folgenden Makro.
Gruß
Franz
Sub AufSpaltenAufteilen()
'Per Komma getrennte Begriffe in Spalte A auf Spalten B bis ... aufteilen
Dim Zeile As Long, Spalte As Long, iI As Long
Dim oCollection As New Collection
Dim arrSplit
Dim wks As Worksheet
Const Zeile1 As Long = 1 'Zeile ab der Begriffe aufgeteilt werden sollen
On Error GoTo Fehler
Set wks = ActiveSheet
With wks
'Alle Begriffe in Spalte A finden
For Zeile = Zeile1 To .Cells(.Rows.Count, 1).End(xlUp).Row
arrSplit = Split(.Cells(Zeile, 1), ",")
For iI = LBound(arrSplit) To UBound(arrSplit)
If Trim(arrSplit(iI)) "" Then
oCollection.Add Item:=Trim(arrSplit(iI)), Key:=Trim(arrSplit(iI))
End If
Next
Next
'Alteintrage ab Spalte 2 löschen
.Range(.Cells(Zeile1, 2), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, _
.UsedRange.Column + .UsedRange.Columns.Count)).ClearContents
'Begriffe auf Spalten aufteilen
For Zeile = Zeile1 To .Cells(.Rows.Count, 1).End(xlUp).Row
arrSplit = Split(.Cells(Zeile, 1), ",")
For iI = LBound(arrSplit) To UBound(arrSplit)
For Spalte = 1 To oCollection.Count
If Trim(arrSplit(iI)) = oCollection.Item(Spalte) Then
.Cells(Zeile, Spalte + 1).Value = Trim(arrSplit(iI))
Exit For
End If
Next
Next
Next
'Begriffe in Zeile unterhalb Liste eintragen
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
For Spalte = 1 To oCollection.Count
.Cells(Zeile, Spalte + 1).Value = oCollection.Item(Spalte)
Next
'Spalten nach Begriffen aufsteigend sortieren
With .Range(.Cells(Zeile1, 2), .Cells(Zeile, oCollection.Count + 1))
.Sort Key1:=.Cells(.Rows.Count, 2), Order1:=xlAscending, Header:=xlNo, _
Orientation:=xlLeftToRight
.EntireColumn.AutoFit
End With
'Zeile mit Begriffen wieder löschen
.Rows(Zeile).ClearContents
End With
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case 457 'Doppelter Collection-Eintrag
Resume Next
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub