AW: mehrspaltiges Verzeichnis sortieren
10.02.2013 16:39:55
fcs
Hallo Mike,
hier ein Makro, dass die mehrspaltigen Daten sortiert.
Muss du halt ggf. noch ein wenig anpassen.
Gruß
Franz
Sub SortierenTitel()
Dim wksOriginal As Worksheet, wksSort As Worksheet
Dim wbk As Workbook
Dim lngZeileMax As Long, lngZeile As Long, intPos As Integer
Set wbk = ActiveWorkbook
Set wksOriginal = ActiveSheet
Application.ScreenUpdating = False
'temporäres Blatt zum Sortieren anlegen
wbk.Worksheets.Add after:=wbk.Sheets(wbk.Sheets.Count)
Set wksSort = wbk.Sheets(wbk.Sheets.Count)
'Originaldaten in temporäres Blatt kopieren
With wksOriginal
lngZeileMax = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(3, 1), .Cells(lngZeileMax, 2)).Copy _
Destination:=wksSort.Cells(1, 1)
.Range(.Cells(3, 3), .Cells(lngZeileMax, 4)).Copy _
Destination:=wksSort.Cells(1 * (lngZeileMax - 2) + 1, 1)
.Range(.Cells(3, 5), .Cells(lngZeileMax, 6)).Copy _
Destination:=wksSort.Cells(2 * (lngZeileMax - 2) + 1, 1)
End With
With wksSort
'Sortieren nach Titel
With .Range(.Cells(1, 1), .Cells(3 * (lngZeileMax - 2), 2))
.Sort Key1:=.Range("B1"), order1:=xlAscending, Header:=xlNo
End With
'nicht benutzte Zeilen löschen
.Range(.Cells(.Rows.Count, 1).End(xlUp), _
.Cells(.Rows.Count, 2).End(xlUp).Offset(1, 0)).Clear
'Zeilen in Spalte A neu nummerieren
With .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
.FormulaR1C1 = "=ROW()"
.Calculate
.Value = .Value
End With
'1. Großbuchstabe im Titel fett
For lngZeile = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
For intPos = 1 To Len(.Cells(lngZeile, 2).Text)
Select Case Asc(Mid(.Cells(lngZeile, 2).Text, intPos, 1))
Case 65 To 91, Asc("Ä"), Asc("Ö"), Asc("Ü")
.Cells(lngZeile, 2).Characters(intPos, 1).Font.Bold = True
Exit For
Case Else
'do nothing
End Select
Next
Next
'Daten wieder ins Original kopieren
.Range(.Cells(1, 1), .Cells(lngZeileMax - 2, 2)).Copy _
Destination:=wksOriginal.Cells(3, 1)
.Range(.Cells(1 * (lngZeileMax - 2) + 1, 1), .Cells(2 * (lngZeileMax - 2), 2)).Copy _
Destination:=wksOriginal.Cells(3, 3)
.Range(.Cells(2 * (lngZeileMax - 2) + 1, 1), .Cells(3 * (lngZeileMax - 2), 2)).Copy _
Destination:=wksOriginal.Cells(3, 5)
'temporäres Blatt wieder löschen
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
wksOriginal.Activate
Application.ScreenUpdating = True
End Sub