Beschleunigung einer Makro

[Dietmar Henning]

Hallo Zusammen,

ich habe eine Makro die in Word ein Inhaltsverzeichnis erstellt.

Leider ist es so, dass es sehr lange dauert bis das Inhaltsverzeichnis erstellt wird.

Kann mir da jemand helfen, dass das Inhaltsverzeichnis schneller erzeugt wird?

Danke für eure Hilfe.

Hier die Makro:

Option Explicit

Sub IHV()
    Dim toc As TableOfContents
    Dim anzAbsaetze As Long
    Dim i As Long

    ' Füge ein neues Inhaltsverzeichnis hinzu
    Set toc = ActiveDocument.TablesOfContents.Add( _
        Range:=Selection.Range, _
        UseHeadingStyles:=False, _
        IncludePageNumbers:=False, _
        RightAlignPageNumbers:=False, _
        UseHyperlinks:=False, _
        HidePageNumbersInWeb:=True, _
        UseOutlineLevels:=False)

    ' Füge die gewünschten Formatvorlagen hinzu
    toc.HeadingStyles.Add style:="Part_Überschrift", level:=1
    toc.HeadingStyles.Add style:="Positionsüberschrift", level:=2
    toc.HeadingStyles.Add style:="Preis", level:=3
    toc.HeadingStyles.Add style:="Option", level:=3
    toc.HeadingStyles.Add style:="Preiszusammenfassung", level:=9

    ' Absätze des IHV zählen
    anzAbsaetze = toc.Range.paragraphs.count
    ' Zusätzliche Schleife über alle Absätze des Inhaltsverzeichnisses von oben nach unten
    With toc.Range
        For i = 1 To anzAbsaetze
            ' Wenn ein Absatz mit 'Verzeichnis 3' formatiert ist...
            If .paragraphs(i).style = "Verzeichnis 3" Then
                ' Ersetze die Worte "Zum Preis von" durch Leerzeichen im IHV
                Call ReplaceTextInTOC(.paragraphs(i).Range, "Zum Preis von", "")
                ' Ersetze die Worte "At a price of" durch Leerzeichen im IHV
                Call ReplaceTextInTOC(.paragraphs(i).Range, "At a price of", "")
            End If
        Next i
    End With

    ' Schleife über alle Absätze des Inhaltsverzeichnisses von unten nach oben
    With toc.Range
        For i = anzAbsaetze To 1 Step -1
            ' Wenn ein Absatz mit 'Verzeichnis 2' formatiert ist...
            If .paragraphs(i).style = "Verzeichnis 2" Then

                '... und wenn der Folgeabsatz Verzeichnis 3 ist...
                If i < anzAbsaetze And .paragraphs(i + 1).style = "Verzeichnis 3" Then

                    ' Entferne die Formatvorlagentrenner und füge die Texte in einer Zeile zusammen:
                    .paragraphs(i).Range.Characters.Last.Select
                    Selection.Delete Unit:=wdCharacter, count:=1

                    ' Füge nach dem Wort "EUR" im Absatz mit Verzeichnis 3 einen Tabulator ein
                    Call InsertTabAfterEUR(.paragraphs(i + 1))
                End If
                ' Füge einen Tabulator vor dem ersten fett formatierten Wort im Absatz mit Verzeichnis 2 ein
                Call InsertTabBeforeFirstBoldWord(.paragraphs(i))
            End If
        Next i
    End With

    ' Überprüfe und formatiere Zeilen, die mit "OP" beginnen
    Call FormatLinesStartingWithOP(toc.Range)

    ' Setze Tabulatoren in kursiv formatierten Zeilen
    Call SetTabsInItalicLines(toc.Range)

    ' Rufe das neue Sub auf, um fett formatierte Wörter im Verzeichnis 2 nicht mehr fett anzuzeigen
    Call RemoveBoldFromVerzeichnis2(toc.Range)
End Sub

Sub ReplaceTextInTOC(rng As Range, findText As String, replaceText As String)
    ' Ersetze Text nur im Inhaltsverzeichnis
    Dim tocRange As Range
    Set tocRange = rng.Duplicate
    With tocRange.Find
        .ClearFormatting
        .Text = findText
        .Replacement.ClearFormatting
        .Replacement.Text = replaceText
        .Wrap = wdFindStop
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Sub InsertTabAfterEUR(paragraph As paragraph)
    ' Füge nach dem Wort "EUR" einen Tabulator ein
    Dim rng As Range
    Set rng = paragraph.Range
    ' Suche nach "EUR" und füge Tabulator hinzu
    With rng.Find
        .ClearFormatting
        .Text = "EUR "
        .Replacement.ClearFormatting
        .Replacement.Text = "EUR" & vbTab
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
End Sub

Sub InsertTabBeforeFirstBoldWord(paragraph As paragraph)
    Dim rng As Range
    Dim charIndex As Long
    Dim foundBold As Boolean

    Set rng = paragraph.Range
    foundBold = False ' Flag, um zu überprüfen, ob ein fett formatiertes Wort gefunden wurde
    ' Durchlaufe jeden Charakter im Absatz
    For charIndex = 1 To rng.Characters.count
        ' Überprüfe, ob das Zeichen fett formatiert ist
        If rng.Characters(charIndex).Font.Bold Then
            ' Füge einen Tabulator vor dem ersten fett formatierten Wort ein
            rng.Characters(charIndex).InsertBefore vbTab
            foundBold = True ' Setze das Flag auf wahr, da ein fett formatiertes Wort gefunden wurde
            Exit For ' Beende die Schleife, nachdem das erste fett formatierte Wort bearbeitet wurde
        End If
    Next charIndex
End Sub

Sub FormatLinesStartingWithOP(rng As Range)
    Dim para As paragraph
    For Each para In rng.paragraphs
        If Left(para.Range.Text, 2) = "OP" Then
            para.Range.Font.Italic = True
        End If
    Next para
End Sub

Sub SetTabsInItalicLines(rng As Range)
    Dim para As paragraph
    For Each para In rng.paragraphs
        If para.Range.Font.Italic Then
            ' Setze den 3. Tabulator auf 9 cm
            para.TabStops.Add Position:=CentimetersToPoints(9), Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces
            ' Setze den 4. Tabulator auf 12,5 cm
            para.TabStops.Add Position:=CentimetersToPoints(12.5), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderSpaces
        End If
    Next para
End Sub
Sub RemoveBoldFromVerzeichnis2(rng As Range)
    Dim para As paragraph
    For Each para In rng.paragraphs
        If para.style = "Verzeichnis 2" Then
            para.Range.Font.Bold = False
        End If
    Next para
End Sub

[Klaus-Dieter]

Hallo,

abgesehen davon, dass es in Word eine Standardfunktion zum Erstellen von Inhaltsverzeichnissen gibt, bist du hier in einem Excelforum, nicht direkt die richtige Anlaufstelle.

[snb]

Ohne Beispieldatei ? Dann dauert es ewig.

[Kuwer]

Thema nach Word verschoben.

[Gerhard H]

Hallo Dietmar,

deine Frage ist ja eine Anschlussfrage von hier: https://www.clever-excel-forum.de/Thread...len?page=2 . Darauf hinzuweisen oder die Frage gleich dort anzuhängen wäre weniger verwirrend gewesen. 

Du solltest trotzdem nochmal ein aktuelles Musterdokument zur Verfügung stellen, denn mein Versuch, rauszufinden ob ich was zur Beschleunigung beitragen kann, scheitert daran, dass in der Hauptprozedur (Sub IHV) eine Formatvorlage "Preiszusammenfassung" angesprochen wird, die es in der letzten Dokumentversion im vorherigen Beitrag nicht gibt, d.h. ich kann das Makro nicht mal ausführen.

[Dietmar Henning]

Hallo Gerhard,

danke für deine Antwort.

Ich konnte die Makro durch die funktion arrays so umarbeiten, dass die Makor jetzt extrem schnell arbeitet.

Sorry das ich deine Zeit verschwändet habe.

Danke für die Hilfe.

Gruss

Dietmar

[Gerhard H]

Hallo Dietmar,

da mach dir mal keine Sorgen. Eine Zeitverschwendung wäre es besonders dann nicht, wenn du so nett wärst, ein Dokument mit dem aktuellen verbesserten Makro hochzuladen. Vielleicht könnte ich oder auch andere dann auch noch was dabei lernen.