AW: Sortierung dreiteiliger Ziffern (1-1-1)
06.06.2013 09:26:17
Klaus
Hallo Lutz,
in deiner Zeile 12 stehen Überschriften, ab Zeile 13 bis unbekannt stehen Inhalte. In Spalte B stehen durchgehend Werte im Format 00-00-00 (wieviele Stellen die jeweils haben ist egal, aber IMMER drei Werte und zwei Bindestriche! Niemals mehr als zwei Bindestriche!).
Fehlerwerte wie #NV und #DIV/0 kommen nicht vor.
Unter diesen Vorraussetzungen sollte folgendes Makro deine Aufgabe lösen:
Sub Macro1()
On Error GoTo hell
Const SpalteDreierIndex As Long = 2
Const ErsteZeile As Long = 12 'Inhalt ab Zeile 12
Dim LastRow As Long
Dim LastCol As Long
Dim r As Range
LastRow = Cells(Rows.Count, SpalteDreierIndex).End(xlUp).Row
'zwei Spalten einfügen
Columns(SpalteDreierIndex).Offset(0, 1).Insert shift:=xlToRight
Columns(SpalteDreierIndex).Offset(0, 1).Insert shift:=xlToRight
'Dreierindex aufteilen auf drei Spalten
Application.DisplayAlerts = False
'Range(Cells(ErsteZeile + 1, SpalteDreierIndex), Cells(LastRow, SpalteDreierIndex)).Select
Range(Cells(ErsteZeile + 1, SpalteDreierIndex), Cells(LastRow, SpalteDreierIndex)). _
TextToColumns _
Destination:=Cells(ErsteZeile + 1, SpalteDreierIndex), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="-", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
TrailingMinusNumbers:=True
Application.DisplayAlerts = True
'sortieren nach drei Spalten
LastCol = Cells(ErsteZeile, Columns.Count).End(xlToLeft).Column
With Range(Cells(ErsteZeile + 1, 1), Cells(LastRow, LastCol))
.Sort _
Key1:=Cells(ErsteZeile, SpalteDreierIndex + 0), Order1:=xlAscending, _
Key2:=Cells(ErsteZeile, SpalteDreierIndex + 1), Order1:=xlAscending, _
Key3:=Cells(ErsteZeile, SpalteDreierIndex + 2), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
.EntireRow.AutoFit
End With
'Dreierindex wieder herstellen
For Each r In Range(Cells(ErsteZeile + 1, SpalteDreierIndex), Cells(LastRow, SpalteDreierIndex)) _
r.Value = "'" & r.Value & "-" & r.Offset(0, 1).Value & "-" & r.Offset(0, 2).Value
Next r
'zwei Spalten löschen
Columns(SpalteDreierIndex).Offset(0, 1).Delete
Columns(SpalteDreierIndex).Offset(0, 1).Delete
GoTo heaven
hell:
MsgBox "Fehler!" & vbCrLf & "Fehlernummer: " & Err.Number & _
vbCrLf & "Fehlerbeschreibung: " & Err.Description
heaven:
Application.DisplayAlerts = True
End Sub
Anmerkung: Das "zwei Spalten löschen / einfügen" könnte man auch eleganter lösen, funktioniert aber so wie es ist.
Grüße,
Klaus M.vdT.