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

Bitte markiere auch die Kommentare, die zur Lösung des Beitrags beigetragen haben

Content-ID: 203022

Url: https://administrator.de/forum/vba-makro-zur-erstellung-eines-alphabetisierten-stichwortverzeichnisses-in-excel-203022.html

Ausgedruckt am: 23.12.2024 um 14:12 Uhr

3 Kommentare

Neuester Kommentar

Hi Rom682013,
hier solltest du Antworten auf deine Fragen finden: Makro für Excel-Suche
Grüße Uwe

Hallo Rom!

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 Sub

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]

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

gelöst Frage VB for Applications Entwicklung

Heiß diskutiert