Textmarker automatisch erstellen

[Dietmar Henning]

Hallo Zusammen,
ich komme leider nicht weiter.
Ich habe ein Makro das 3 verschiedene Buchstabenkombinationen in einer Word-Datei suchen soll und dann automatisch, wenn das Makro diese findet Textmarker erstellen soll.
Die 3 Kombinationen lauten cvx() , zys(-) und wqz(/).
Das Makro findet auch die erste Buchstabenkombination cvx() und vergibt Textmarken aber leider nicht bei den anderen beiden.
Kann mir jemand von euch weiterhelfen?
Im Anhang findet Ihr eine Excel-Datei wo das Makro enthalten ist und eine Word-Datei wo die Buchstabenkombinaten enthalten sind.
Danke für die Hilfe.

[Egon12]

Hallo,

Es gibt 2 Probleme:
1. Schreibfehler
ändere die Zeile so:
searchTerms = Array("cvx()", "zys(-)", "wqz(-)")

2. Do While Schleife
Die Schleife läuft endlos, da der Fund vorhanden ist. Die Schleife wird nur verlassen, wenn .Found=False

Du kannst (ich lass mich gern eines besseren Belehren) nur via Zählvariable die Schleife verlassen, da foundRange.Find.Found bei jedem Schleifendurchlauf True ist.

Code:

Dim j&
Do While .Found
    foundRange.Bookmarks.Add Name:=bookmarkName & "_" & foundRange.Start, Range:=foundRange
    ' Suche nach dem nächsten Vorkommen
    foundRange.Collapse Direction:=0 ' wdCollapseEnd
    .Execute
    j = j + 1
    If j = 100 Then Exit Do
Loop
j=0

ich würde es dann so eher lösen:

Code:

If .Found = True Then
    For j = 1 To 100
        foundRange.Bookmarks.Add Name:=bookmarkName & "_" & foundRange.Start, Range:=foundRange
        ' Suche nach dem nächsten Vorkommen
        foundRange.Collapse Direction:=wdCollapseEnd  ' wdCollapseEnd
        .Execute
    Next j
End If

Gruß Uwe

[Dietmar Henning]

Hallo Uwe,

ich danke dir für für den Hinweis.

Die Makro funktioniert jetzt perfekt.

Ich wünsche dir noch eine schöne Rest Woche.

Gruß

Robert

[Egon12]

Hallo Robert,
 
ich hatte jetzt mal etwas Zeit mich um das Problem - wie viele Funde pro Suchstring - gibt es zu kümmern.
Jetzt werden nur noch Schleifendurchläufe (j Schleife) entsprechend der Trefferzahl durchgeführt.
Das ist zeitsparender als eine mögliche Maximalzahl festzulegen.

Code:

Sub MarkTextInWord()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdFunde As Object
    Dim foundRange As Object
    Dim searchTerms()
    Dim i&, j&, k&
    Dim bookmarkName$, filePath$

    ' Suchbegriffe definieren
    searchTerms = Array("cvx()", "zys(-)", "wqz(-)")

    ' Word-Anwendung starten
    On Error Resume Next
    Set wdApp = CreateObject("Word.Application")
    On Error GoTo 0

    ' Dialogfeld zum Öffnen der Word-Datei
    filePath = Application.GetOpenFilename("Word-Dateien (*.docx; *.doc), *.docx; *.doc", , "Wählen Sie eine Word-Datei")

    ' Überprüfen, ob eine Datei ausgewählt wurde
    If filePath = "False" Then
        MsgBox "Keine Datei ausgewählt. Das Makro wird beendet."
        Exit Sub
    End If

    ' Word-Dokument öffnen
    Set wdDoc = wdApp.Documents.Open(filePath)
    wdApp.Visible = True

    ' Durchsuche das Dokument nach den Suchbegriffen und setze Textmarken
    For i = LBound(searchTerms) To UBound(searchTerms)
        Set wdFunde = wdDoc.ActiveWindow
        With wdFunde.Selection   ' Zählen der vorhandenen Funde zum jeweiligen Suchstring
            .HomeKey Unit:=wdStory
            With .Find
                .Text = searchTerms(i)
                .Forward = True
            End With
            Do While .Find.Execute
                k = k + 1
            Loop
        End With

        Set foundRange = wdDoc.Content
        bookmarkName = "Bookmark_" & i ' Erstelle einen eindeutigen Namen für die Textmarke

        With foundRange.Find
            .ClearFormatting
            .Text = searchTerms(i)
            .Wrap = 1 ' wdFindContinue
            .MatchCase = False ' Groß-/Kleinschreibung ignorieren
            .MatchWholeWord = False ' Ganze Wörter nicht erforderlich
            .Forward = True ' Suche vorwärts
            .Execute

            ' Wenn gefunden, Textmarke setzen
            If .Found = True Then
                For j = 1 To k
                    foundRange.Bookmarks.Add Name:=bookmarkName & "_" & foundRange.Start, Range:=foundRange
                    ' Suche nach dem nächsten Vorkommen
                    foundRange.Collapse Direction:=wdCollapseEnd  ' wdCollapseEnd
                    .Execute
                Next j
            End If
        End With
        k = 0
    Next i

    ' Dokument speichern und schließen
    wdDoc.Save
    wdDoc.Close
    wdApp.Quit

    ' Objekte freigeben
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set wdFunde = Nothing

    MsgBox "Die Buchstabenkombinationen wurden mit Textmarken versehen und das Dokument wurde geschlossen."
End Sub

 
Gruß Uwe

[Egon12]

Hallo Robert,

Das Thema hat mir keine Ruhe gelassen.
Nun mit einer Schleife weniger entsprechend kompakt:

Code:

Option Explicit

Sub MarkTextInWord()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdFunde As Object
    Dim foundRange As Object
    Dim searchTerms()
    Dim i&, j&, k&
    Dim bookmarkName$, filePath$

    ' Suchbegriffe definieren
    searchTerms = Array("cvx()", "zys(-)", "wqz(-)")

    ' Word-Anwendung starten
    On Error Resume Next
    Set wdApp = CreateObject("Word.Application")
    On Error GoTo 0

    ' Dialogfeld zum Öffnen der Word-Datei
    filePath = Application.GetOpenFilename("Word-Dateien (*.docx; *.doc), *.docx; *.doc", , "Wählen Sie eine Word-Datei")

    ' Überprüfen, ob eine Datei ausgewählt wurde
    If filePath = "False" Then
        MsgBox "Keine Datei ausgewählt. Das Makro wird beendet."
        Exit Sub
    End If

    ' Word-Dokument öffnen
    Set wdDoc = wdApp.Documents.Open(filePath)
    wdApp.Visible = True

    ' Durchsuche das Dokument nach den Suchbegriffen und setze Textmarken
    For i = LBound(searchTerms) To UBound(searchTerms)
        Set wdFunde = wdDoc.ActiveWindow
        Set foundRange = wdDoc.Content
        bookmarkName = "Bookmark_" & i ' Erstelle einen eindeutigen Namen für die Textmarke
       
        With wdFunde.Selection
            .HomeKey Unit:=wdStory
            With .Find
                .Text = searchTerms(i)
                .Forward = True
            End With
            With foundRange.Find
                .ClearFormatting
                .Text = searchTerms(i)
                .Wrap = 1 ' wdFindContinue
                .MatchCase = False ' Groß-/Kleinschreibung ignorieren
                .MatchWholeWord = False ' Ganze Wörter nicht erforderlich
                .Forward = True ' Suche vorwärts
                .Execute
            End With
            Do While .Find.Execute  ' Schleife
                foundRange.Bookmarks.Add Name:=bookmarkName & "_" & foundRange.Start, Range:=foundRange
                ' Suche nach dem nächsten Vorkommen
                foundRange.Collapse Direction:=wdCollapseEnd  ' wdCollapseEnd
                foundRange.Find.Execute
            Loop
        End With
    Next i
    ' Dokument speichern und schließen
    wdDoc.Save
    wdDoc.Close
    wdApp.Quit
    ' Objekte freigeben
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set wdFunde = Nothing
    MsgBox "Die Buchstabenkombinationen wurden mit Textmarken versehen und das Dokument wurde geschlossen."
End Sub

Gruß Uwe

[Dietmar Henning]

Hallo Uwe,

das ist ja wirklich der Hammer, dass geht jetzt wirklich schneller.
Danke dir für deine Hilfe und deiner Zeit.

Ich hätte nochmal eine Frage zu der Makro -> Übertragung von Daten in Word.

Wenn ich die Makro aktiviere sagt er mir jetzt immer Laufzeitfehler '9' Index außerhalb des gültigen Bereichs.
Ich dachte mir dann, weil die Makro das Wort Text nicht findet bei den automatsch erstellten Textmarken, sag ich der Makro die die Textmarken erstellt, dass das Wort Text mit eingearbeitet werden soll.
Dies funktioniert auch.
Die Textmarken heißen jetzt text in der Word-Datei.
Doch leider bekomme ich immer noch den Laufzeitfehler in der Makro -> Übertragung von Daten in Word .

Beim Debuggen zeigt er mir die Zeile arrWerteTxT(i) = .Cells(arrItem(i), 2).

Ich weiß nicht warum Array keine Werte erhält.

Kannst du mir sagen was ich hier falsch machen.

Danke für deine Hilfe.

Gruß
Robert

[snb]

Warum in Excel ?
In Word ist das schon eingebaut.: Highlight=true

[Egon12]

Hallo Robert,
 
die Probleme sind wieder hausgemacht.
Die Verwendung von nur einem Teilstring lässt sich via Auswertung der Zählvariable lösen.
Auch das ungleiche Verhältnis zwischen Bookmarks und vorhandenen Einträgen in der Tabelle kann mit Auswertung der Zählvariable geschehen.
 
Das eigentliche Problem ist die ursprüngliche Festlegung Bookmarks von oben nach unten.
Durch die vorherigen Fehlerausgaben ist dir dabei das eigentliche Problem noch gar nicht sichtbar geworden.
 
Du hast dazu meine letzte Prozedur verwendet um die Bookmarks zu setzen.
Wenn du dir den Ablauf anschaust, wirst du feststellen, dass diese (Array der Suchstrings) 3x von vorn das Textdokument durchsucht und dazu die Bookmarks setzt.
 
Also passt hier der Topf überhaupt nicht zum Deckel.
Es wäre besser, wenn du dir bevor du überhaupt über Programmierung nachdenkst, zu allererst ein Bild machst, wie was sauber und eindeutig funktionieren soll.
Dazu müssen alle Strukturen klar festgelegt sein. Dann kann man sich über die Programmierung (Lösungswege etappenweise) einen Plan bauen.
 
Diesen nimmst du und baust alles, was du selbst kannst. Bleiben Fragen kann man diese in den Foren stellen und wird dann auch entsprechende Hilfe bzw. Erklärungen dazu erhalten.
 
Ich habe schon extrem weit geholfen teilweise sogar um dir die nötige Systematik zu vermitteln.
Der Grund war, dass mich die Programmierung als Solche interessierte.
 
Nun bist du an der Reihe den Kram von den Voraussetzungen her beginnend erst mal aufzuräumen um ein systematisches Herangehen überhaupt erst zu ermöglichen.
 
Auch wenn es dir unter den Nägeln brennt ein Ergebnis zu erhalten, dies überfordert dich derzeit massiv. Beschäftige dich in Ruhe mit VBA und Programmierstrukturen.
 
 Gruß Uwe

[Dietmar Henning]

Hallo Uwe,

danke für deine Hinweise und Ratschläge.
Ich werde Versuchen Sie umzusetzen.
Vielleicht bekomme ich es ja hin.

Nochmal danke für deine Zeit und für die tolle Hilfe in den letzten Tagen.

Ich wünsche dir und deiner Familie alles gute und eine schönes Wochenende.

Gruß

Robert

[Dietmar Henning]

Hallo Uwe,

ich wollte dir nur nochmal mitteilen, dass ich es jetzt hinbekommen habe.

Ich habe die Makro die die Textmarken erstellt gesagt, dass Sie bei der Buchstabenkombination "cvx ()" das Wort Text in die Textmarke reinschreiben soll und bei der Buchstabenkombination "zys(-)" VKPreis reinschreiben soll und bei "wqz(/)" Summe.

Somit hat deine Makro dann wieder perfekt funktioniert.
Ich habe es jetzt schon mehrmals ausprobiert auch bei anderen Texten und es funktioniert wunderbar.

Hier für dich wenn du magst die angepasst Makro die die Textmarken erstellt:

Option Explicit

Sub MarkTextInWordAutomatischErstellen()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdFunde As Object
    Dim foundRange As Object
    Dim searchTerms()
    Dim i&, j&, k&
    Dim bookmarkName$, filePath$

    ' Suchbegriffe definieren
    searchTerms = Array("cvx()", "zys(-)", "wqz(/)")

    ' Word-Anwendung starten
    On Error Resume Next
    Set wdApp = CreateObject("Word.Application")
    On Error GoTo 0

    ' Dialogfeld zum Öffnen der Word-Datei
    filePath = Application.GetOpenFilename("Word-Dateien (*.docx; *.doc), *.docx; *.doc", , "Wählen Sie eine Word-Datei")

    ' Überprüfen, ob eine Datei ausgewählt wurde
    If filePath = "False" Then
        MsgBox "Keine Datei ausgewählt. Das Makro wird beendet."
        Exit Sub
    End If

    ' Word-Dokument öffnen
    Set wdDoc = wdApp.Documents.Open(filePath)
    wdApp.Visible = True

    ' Durchsuche das Dokument nach den Suchbegriffen und setze Textmarken
    For i = LBound(searchTerms) To UBound(searchTerms)
        Set wdFunde = wdDoc.ActiveWindow
        With wdFunde.Selection  ' Zählen der vorhandenen Funde zum jeweiligen Suchstring
            .HomeKey Unit:=wdStory
            With .Find
                .Text = searchTerms(i)
                .Forward = True
            End With
            Do While .Find.Execute
                k = k + 1
            Loop
        End With

        Set foundRange = wdDoc.Content

        ' Bestimme den Textmarkennamen basierend auf dem Suchbegriff
        Select Case searchTerms(i)
            Case "cvx()"
                bookmarkName = "Text"
            Case "zys(-)"
                bookmarkName = "VKPreis"
            Case "wqz(/)"
                bookmarkName = "Summe"
        End Select

        With foundRange.Find
            .ClearFormatting
            .Text = searchTerms(i)
            .Wrap = 1 ' wdFindContinue
            .MatchCase = False ' Groß-/Kleinschreibung ignorieren
            .MatchWholeWord = False ' Ganze Wörter nicht erforderlich
            .Forward = True ' Suche vorwärts
            .Execute

            ' Wenn gefunden, Textmarke setzen
            If .Found = True Then
                For j = 1 To k
                    foundRange.Bookmarks.Add Name:=bookmarkName & foundRange.Start, Range:=foundRange
                    ' Suche nach dem nächsten Vorkommen
                    foundRange.Collapse Direction:=wdCollapseEnd  ' wdCollapseEnd
                    .Execute
                Next j
            End If
        End With
        k = 0
    Next i

    ' Objekte freigeben
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Set wdFunde = Nothing

    MsgBox "Die Buchstabenkombinationen wurden mit Textmarken versehen."
End Sub

Danke nochmal für dein Hilfe und deinen tollen Worten.