für eine Inhaltsanalyse möchte ich ein Worddokument mithilfe eines Excel-Wörterbuchs durchsuchen, die Treffer einfärben, zählen und den jeweiligen Fundort samt Trefferanzahl je Wort in das Excel-Wörterbuch schreiben, bspw. in Spalte B und C.
Bisher ist es mir mithilfe diverser Codeschnipsel und Anpassungen nur gelungen, die Treffer einzufärben und zu zählen, siehe hierzu unten stehender Code. Vor allem dauert das Ausführen des Skriptes bei meinem 4000-Seiten-Dokument fast eine Viertelstunde... ist das normal?
Könnt ihr mir bitte weiterhelfen?
Vielen Dank!
Sub KEYWORDS_SUCHEN_UND_ZAEHLEN()
' KEYWORDS SUCHEN
' UND FARBIG HERVORHEBEN
Dim myRange As Range, AktWord As Variant
Dim AllWord() As String, iWord As Long, Found As Boolean
Dim TmpStr As String
Set myRange = ActiveDocument.Range
' Exceldaten aus offener Arbeitsmappe einlesen
' Aktuell: 1. Spalte Zeile 1-200
Dim xlApp As Object ' Excel.Application
Dim SuchRange As Object, AktZelle As Object
Set xlApp = GetObject(, "Excel.Application")
Set SuchRange = xlApp.Range("A1:A200")
With SuchRange
For Each AktZelle In SuchRange
If Len(AktZelle & "") > 0 Then
ReDim Preserve AllWord(iWord)
AllWord(iWord) = UCase(AktZelle)
iWord = iWord + 1
End If
Next
End With
' Worddokument durchsuchen und Wörter Rot färben
Set myRange = ActiveDocument.Range
With myRange
For Each AktWord In .Words
TmpStr = Trim(AktWord.Text)
For iWord = 0 To UBound(AllWord)
If UCase(TmpStr) Like AllWord(iWord) & "*" Then
AktWord.Font.Color = wdColorRed
End If
Next
Next
End With
Set SuchRange = Nothing
Set myRange = Nothing
' FARBIG HERVORGEHOBENE
' KEYWORDS ZÄHLEN
Dim highlightCount
highlightCount = 0
For Each w In ActiveDocument.Words
If w.Font.Color = wdColorRed Then
'w.Delete
highlightCount = highlightCount + 1
End If
Next
MsgBox ("Das Dokument enthält " & highlightCount & " Übereinstimmungen mit dem Wörterbuch.")
End Sub