Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1296to1300
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

mehrspaltiges Verzeichnis sortieren

mehrspaltiges Verzeichnis sortieren
10.02.2013 13:33:21
mike49
Hallo zusammen,
ich habe ein mehrspaltiges Verzeichnis erstellt, bei dem in A2:A71 die Titelnummern stehen und in der B-Spalte die dazugehörigen Titelnamen. Die Fortsezung der Nummern folgt mit E2:E71 und I2:I71. Die dazugehörigen Titel stehen in den entsprechenden Spalten daneben. Sind die Nummern erweitert (z.B. 6 und 6a)ändert sich dementsprechend die Schlussnummer.
Ich möchte nun mit einem Makro das Verzeichnis nach Titelnamen sortieren. Die nicht verwendeten Nummern und leeren Titel sollen gelöscht werden. Schön wäre es noch, wenn der erste Großbuchstabe der unter A, B, C usw.aufgelisteten Titel fett hervorgehoben würde.
Der Anschaulichkeit und Integrierens wegen lade ich Datei mal hoch:
https://www.herber.de/bbs/user/83831.xls
Ich würde mich freuen, wenns hierfür eine Lösung gäbe.
Gruß
mike49

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
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

Anzeige
AW: mehrspaltiges Verzeichnis sortieren
10.02.2013 18:08:15
mike49
Hallo Franz,
danke dir für die schnelle Hilfe. Ich musste jedoch dringend weg und bin erst jetzt wieder zurück.
Ich habe mal getestet und dein Makro ins Arbeitsblatt kopiert. Leider funktioniert es noch nicht so wie ich's gerne hätte und meine VBA-Kenntnisse sind nicht so gut, um dies anpassen zu können. Vielleicht könntest du's mal testen. Du wirst dann sehen, dass die erweiterten Nummern wie 6a, 17a usw. beim Sortieren rausfallen,die Nummern im zweiten Sortierbereich falsch übertragen werden. Desweiteren bleiben Leerzeilen stehen (es sollte ohne Leerzellen sortiert werden.
Das mit dem fettgedruckten Anfangsbuchstaben meinte ich so:Die Sortierung sortiert so, dass erst alle Titel mit A aufsteigend sortiert werden, dann alle Titel mit B usw. bis Z. Ich wollte, dass nur der 1. Buchstabe des 1. Eintrags der jeweiligen Buchstabengruppe fettgedruckt wird. Alle nachfolgenden 1. Buchstaben der Gruppe sollen nicht fett sein. Dadurch will ich erreichen, dass ich bei einer Titelsuche die Gruppe schneller finde.
Vielleicht kannst du dir's ja nochmals anschauen.
Gruß
mike49

Anzeige
AW: mehrspaltiges Verzeichnis sortieren
10.02.2013 19:35:51
fcs
Hallo Mike,
ich hab jetzt die Neunummerierung der Zeilen weggelassen.
Ansonsten müsstets du mal eine Beispiel-Datei hochladen, die die Sondernummerierungen 6, 6a, 17, 17a etc. und andere SOnderfälle enthält und wie das Ganze dann nach dem Sortieren der Titel aussehen soll. Aus denem beschreibenden Text verstehe ich zum Teil leider nur Bahnhof.
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
Dim strBS As String
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
'1. Buchstabe im Titel fett, wenn 1. Buchstabe wechselt
strBS = ""
For lngZeile = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If strBS  Left(.Cells(lngZeile, 2).Text, 1) Then
.Cells(lngZeile, 2).Characters(1, 1).Font.Bold = True
strBS = Left(.Cells(lngZeile, 2).Text, 1)
End If
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

Anzeige
AW: mehrspaltiges Verzeichnis sortieren
10.02.2013 20:11:06
mike49
Hallo Franz,
zum besseren Verständnis lade ich mal beide Dateien hoch:
https://www.herber.de/bbs/user/83840.xlsx
https://www.herber.de/bbs/user/83841.xlsx (so soll's nach dem Sortieren aussehen.
Das A bei Nr. 70, das B Nr. 127 usw. sind fett hervorgehoben. Das zeigt mir den Beginn der Titelgruppe die mit A, B usw. beginnt. So wird die alphabetische Titelsuche erleichtert.
Gruß
mike49

AW: mehrspaltiges Verzeichnis sortieren
10.02.2013 20:15:13
mike49
Hi Franz,
die Hervorhebung der Anfangsbuchstaben kannst du auch weglassen. Wichtig ist mir die richtige alphabetische Sortierung.
Gruß
mike49

Anzeige
AW: mehrspaltiges Verzeichnis sortieren
11.02.2013 07:18:08
fcs
Hallo Mike,
hier nochmals das Makro angepasst bezüglich der Zeilen und Spalten.
Leider hatte deine 1. hochgeladene Beispieldatei einen einen anderen Spaltenaufbau und die zu sortierenden Daten beginnen jetzt in Zeile 2. Da musste ich jetzt einiges noch wieder 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
Dim strBS As String
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(2, 1), .Cells(lngZeileMax, 3)).Copy _
Destination:=wksSort.Cells(1, 1)
.Range(.Cells(2, 5), .Cells(lngZeileMax, 7)).Copy _
Destination:=wksSort.Cells(1 * (lngZeileMax - 1) + 1, 1)
.Range(.Cells(2, 9), .Cells(lngZeileMax, 11)).Copy _
Destination:=wksSort.Cells(2 * (lngZeileMax - 1) + 1, 1)
End With
With wksSort
'Sortieren nach Titel
With .Range(.Cells(1, 1), .Cells(3 * (lngZeileMax - 2), 3))
.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, 2)).ClearContents
'1. Buchstabe im Titel fett, wenn 1. Buchstabe wechselt
strBS = ""
For lngZeile = 1 To .Cells(.Rows.Count, 1).End(xlUp).Row
If strBS  Left(.Cells(lngZeile, 2).Text, 1) Then
.Cells(lngZeile, 2).Characters(1, 1).Font.Bold = True
strBS = Left(.Cells(lngZeile, 2).Text, 1)
End If
Next
'Daten wieder ins Original kopieren
.Range(.Cells(1, 1), .Cells(lngZeileMax - 1, 3)).Copy _
Destination:=wksOriginal.Cells(2, 1)
.Range(.Cells(1 * (lngZeileMax - 1) + 1, 1), .Cells(2 * (lngZeileMax - 1), 3)).Copy _
Destination:=wksOriginal.Cells(2, 5)
.Range(.Cells(2 * (lngZeileMax - 1) + 1, 1), .Cells(3 * (lngZeileMax - 1), 3)).Copy _
Destination:=wksOriginal.Cells(2, 9)
'temporäres Blatt wieder löschen
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
End With
wksOriginal.Activate
Application.ScreenUpdating = True
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige