3
VBA - Makro zur Erstellung eines alphabetisierten Stichwortverzeichnisses in Excel
Liebe Profis,
wer kann mir von Euch helfen. Ich habe folgendes Problem:
In einer Excel-Arbeitsmappe habe ich unter anderem drei Arbeitsblätter: System, Schlagwörter und Stichwortverzeichnis. Nun soll im Arbeitsblatt „System“ in der Spalte A nach Schlagwörtern, die in Arbeitsblatt „Schlagwörter“ Spalte A ab Zelle 3 enthalten sind, gesucht werden. Wenn wahr, dann soll die ganze Zeile, da auch Einträge in Spalten B bis D vorhanden sind, kopiert und in Arbeitsblatt „Stichwortverzeichnis“ (bislang leer) eingefügt werden. Zudem soll variabel gesucht werden, d. h. Schlagwort „Verzeichnis“ Ausgabe „Verzeichnis“ und/oder „Verzeichnisses“ und/oder „Verzeichnisse“ bzw. Schlagwort „Auf- und Abbauten“ Ausgabe „ Auf- und Abbauten“ und/oder „auf- und abbau“. Das Arbeitsblatt „Stichwortverzeichnis“ soll wie folgt aufgebaut werden:
A
Such-Schlagwort
Ausgabe aus „System“
Ausgabe aus „System“
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
usw.
B
Such-Schlagwort
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
usw.
C
Such-Schlagwort
Ausgabe aus „System“
usw.
bis Z
Ich scheitere bereits beim Kopieren in das Arbeitsblatt „Stichwortverzeichnis“. Derzeit wird alles eingefügt, nur nicht das wonach ich suche.
Mein derzeitiges Makro lautet:
Sheets("SysKopie").Activate
Dim A, B, C, D, E, F
Dim Suchbegriff As String
Sheets("SysKopie").Select
A = Range(Sheets("Schlagwörter").Cells(1, 1), Sheets("Schlagwörter").Cells(1, 1).End(xlDown)).Rows.Count
B = Range(Sheets("SysKopie").Cells(1, 1), Sheets("SysKopie").Cells(1, 1).End(xlDown)).Rows.Count
For C = 2 To B
Suchbegriff = Sheets("Schlagwörter").Cells(C, 1).Value
For D = 2 To A
Cells(D, 1).Select 'kann man weglassen, man sieht aber wo man ist
E = Cells(D, 1).Value
F = InStr(1, E, Suchbegriff, vbTextCompare)
If F > 0 Then
ActiveCell.EntireRow.Copy
Sheets("Stichwortverzeichnis").Range("A" & zelle.Row) = zelle.Offset(0, 1)
End If
F = 0
Next D
Next C
Sheets("Stichwortverzeichnis").Activate
Cells(3, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _
8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21), Header:=xlNo
Und bleibt im Testlauf bei der Zeile
Sheets("Stichwortverzeichnis").Range("A" & zelle.Row) = zelle.Offset(0, 1)
stehen.
Wer kann mir da helfen. Im Voraus besten Dank!
Viele Grüße
Rom682013
A
Such-Schlagwort
Ausgabe aus „System“
Ausgabe aus „System“
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
usw.
B
Such-Schlagwort
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
Ausgabe aus „System“
Such-Schlagwort
Ausgabe aus „System“
usw.
C
Such-Schlagwort
Ausgabe aus „System“
usw.
bis Z
Ich scheitere bereits beim Kopieren in das Arbeitsblatt „Stichwortverzeichnis“. Derzeit wird alles eingefügt, nur nicht das wonach ich suche.
Mein derzeitiges Makro lautet:
Sheets("SysKopie").Activate
Dim A, B, C, D, E, F
Dim Suchbegriff As String
Sheets("SysKopie").Select
A = Range(Sheets("Schlagwörter").Cells(1, 1), Sheets("Schlagwörter").Cells(1, 1).End(xlDown)).Rows.Count
B = Range(Sheets("SysKopie").Cells(1, 1), Sheets("SysKopie").Cells(1, 1).End(xlDown)).Rows.Count
For C = 2 To B
Suchbegriff = Sheets("Schlagwörter").Cells(C, 1).Value
For D = 2 To A
Cells(D, 1).Select 'kann man weglassen, man sieht aber wo man ist
E = Cells(D, 1).Value
F = InStr(1, E, Suchbegriff, vbTextCompare)
If F > 0 Then
ActiveCell.EntireRow.Copy
Sheets("Stichwortverzeichnis").Range("A" & zelle.Row) = zelle.Offset(0, 1)
End If
F = 0
Next D
Next C
Sheets("Stichwortverzeichnis").Activate
Cells(3, 1).Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, _
8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21), Header:=xlNo
Und bleibt im Testlauf bei der Zeile
Sheets("Stichwortverzeichnis").Range("A" & zelle.Row) = zelle.Offset(0, 1)
stehen.
Wer kann mir da helfen. Im Voraus besten Dank!
Viele Grüße
Rom682013
Share on Facebook
Share on Twitter
Share on Reddit
Share on LinkedinPlease also mark the comments that contributed to the solution of the article
Content-Key: 203022
Url: https://administrator.de/contentid/203022
Printed on: April 25, 2024 at 04:04 o'clock
3 Comments
Latest comment
Hallo Rom!
Auf Basis der per Mail erhaltenen Beispieldatei könnte das schematisch etwa so gehen:
Zusätzliche Formatierungen, andere Suchparameter (Zeile 34), etc bekommst Du ja bei Bedarf vielleicht auch selbst hin ...
Grüße
bastla
[Edit] Statusleistenanzeige hinzugefügt [/Edit]
Auf Basis der per Mail erhaltenen Beispieldatei könnte das schematisch etwa so gehen:
Sub Stichwortverzeichnis_erstellen()
SchlagTabelle = "Schlagwörter"
QuellTabelle = "SysKopie"
ZielTabelle = "Stichwortverzeichnis"
SchlagAb = "A3" 'Zelle mit erstem Schlagwort
QuellSpalte = "A" 'erste Datenspalte der Quelldatei - hier wird gesucht
QuellSpaltenAnzahl = 3 'Anzahl zu kopierender Spalten
ZielAb = "A3" 'erste Zelle der Zieldatei
Set STab = Worksheets(SchlagTabelle)
Set QTab = Worksheets(QuellTabelle)
Set ZTab = Worksheets(ZielTabelle)
SZeile = STab.Range(SchlagAb).Row
SSpalte = STab.Range(SchlagAb).Column
ZZeile = ZTab.Range(ZielAb).Row
ZSpalte = ZTab.Range(ZielAb).Column
Application.StatusBar = True 'Anzeige in Statusleiste aktivieren
Schlagwort = STab.Cells(SZeile, SSpalte).Value 'erstes Schlagwort auslesen
Do While Schlagwort <> "" 'wiederholen. solange noch Schlagwörter gefunden werden
Buchstabe = UCase(Left(Schlagwort, 1)) 'Anfangsbuchstabe
If Buchstabe <> BuchstabeZuletzt Then 'neuer Buchstabe?
ZTab.Cells(ZZeile, ZSpalte).Value = Buchstabe 'Buchstaben eintragen ...
ZTab.Cells(ZZeile, ZSpalte).Font.Bold = True '... fett formatieren ...
BuchstabeZuletzt = Buchstabe '... und merken
ZZeile = ZZeile + 1 'nächste Zeile in Zieldatei
Application.StatusBar = "Bearbeite Buchstabe: " & Buchstabe 'Aktuell bearbeiteten Buchstaben in der Stautsleiste anzeigen
End If
Set c = QTab.Columns(QuellSpalte).Find(Schlagwort, LookIn:=xlValues) 'gesamte Spalte durchsuchen
If Not c Is Nothing Then 'gefunden?
ZTab.Cells(ZZeile, ZSpalte).Value = Schlagwort 'Schlagwort eintragen ...
ZTab.Cells(ZZeile, ZSpalte).Font.Bold = True '... und fett formatieren
STab.Cells(SZeile, SSpalte).Offset(0, 1).Value = "vorhanden"
ZZeile = ZZeile + 1 'nächste Zeile der Zieltabelle
Zuerst = c.Address 'erste Fundstelle merken
Do
c.Resize(1, QuellSpaltenAnzahl).Copy ZTab.Cells(ZZeile, ZSpalte)
ZZeile = ZZeile + 1 'nächste Zeile in Zieldatei
Set c = QTab.Columns(QuellSpalte).FindNext(c) 'weitersuchen
Loop While Not c Is Nothing And c.Address <> Zuerst 'bis nix oder erster Fund gefunden wird
ZZeile = ZZeile + 1 'für Leerzeile in Zieldatei
Else 'Schlagwort nicht gefunden
STab.Cells(SZeile, SSpalte).Offset(0, 1).Value = "nicht vorhanden"
End If
SZeile = SZeile + 1 'nächste Zeile in Schlagworttabelle
Schlagwort = STab.Cells(SZeile, SSpalte).Value 'nächstes Schlagwort auslesen
Loop
Application.StatusBar = False 'Statusleistenanzeige abschalten
MsgBox "Fertig."
End SubGrüße
bastla
[Edit] Statusleistenanzeige hinzugefügt [/Edit]
1
Hallo bastla,
vielen, vielen lieben Dank! Das Makro funktioniert bestens. Ich hätte das auf die Schnelle nie so hinbekommen. Danke auch für die Kommentierungen. Den „Rest“ bekomme ich selber hin.
Ich sag nur: „You’re the best champion of the year“.
Viele Grüße
Rom
vielen, vielen lieben Dank! Das Makro funktioniert bestens. Ich hätte das auf die Schnelle nie so hinbekommen. Danke auch für die Kommentierungen. Den „Rest“ bekomme ich selber hin.
Ich sag nur: „You’re the best champion of the year“.
Viele Grüße
Rom
