Wordmakro zählt, wie oft ein Wort im Text vorkommt

Makros können uns in den Officeprogrammen beim Texten die Arbeit wesentlich erleichtern. Bekanntlich neigen wir dazu, immer wieder gleiche Wörter zu verwenden, was gelegentlich nicht erwünscht ist.

Folgendes Makro habe ich letzthin mit einem Newsletter erhalten. Es ist also nicht auf meinem Mist gewachsen, aber es darf weitergegeben werden. Wenn Sie den Code ausführen, wird gezählt, wie oft ein Wort im Text vorkommt. Sofern ein guter Sprachstil in einem Text besonders wichtig ist, lasse ich den Code gelegentlich ausführen. Am besten legt man dazu ein Icon in eine Symbolleiste. Wer die Makrosprache etwas versteht, kann den Code vielleicht noch etwas optimieren.

zur Bildschirmaufzeichnung



Sub WortFrequenzZaehlen()
Const MaxWorte = 10000
Const cstrAusschl = "[der][die][das][ein][eine]" & _
"[einer][wer][wie][was][wo][ist][und][oder]"
Dim strWort As String
Dim arrWorte(1 To MaxWorte, 1 To 2) As String
Dim lngWorteTotal As Long
Dim intNumWorte As Integer
Dim Found As Boolean
Dim strSort As String
Dim varAktWort As Variant
Dim J As Integer

Nochmal:
strSort = InputBox$("Sortieren nach [W]orten oder " & _
"nach [A]nzahl?", "Sortierung:", "A")
If strSort = "" Then Exit Sub
strSort = UCase$(strSort)
If strSort <> "W" And strSort <> "A" Then
Beep
MsgBox "Bitte 'W' oder 'A' eingeben!", vbOKOnly + _
vbExclamation, "!!! Problem !!!"
GoTo Nochmal
End If

System.Cursor = wdCursorWait
Selection.HomeKey Unit:=wdStory
lngWorteTotal = ActiveDocument.Words.Count
intNumWorte = 0

For Each varAktWort In ActiveDocument.Words
strWort = Trim(LCase(varAktWort))
If strWort < "a" Or strWort > "z" Then strWort = ""
If InStr(cstrAusschl, _
"[" & strWort & "]") Then strWort = ""
If Len(strWort) > 0 Then
Found = False
For J = 1 To intNumWorte
If arrWorte(J, 1) = strWort Then
arrWorte(J, 2) = arrWorte(J, 2) + 1
Found = True
Exit For
End If
Next J
If Not Found Then
intNumWorte = intNumWorte + 1
arrWorte(intNumWorte, 1) = strWort
arrWorte(intNumWorte, 2) = 1
End If
If intNumWorte > MaxWorte - 1 Then
Beep
MsgBox "Dokument hat mehr als 10.000 Worte...", _
vbOKOnly + vbInformation, "!!! Problem !!!"
Exit For
End If
End If
lngWorteTotal = lngWorteTotal - 1
StatusBar = "Bearbeite Wort " & intNumWorte & _
" von " & lngWorteTotal
Next varAktWort

'In neues Dokument schreiben
Documents.Add
With Selection
For J = 1 To intNumWorte
.TypeText Trim$(arrWorte(J, 1)) &amp;amp; vbTab & _
Format$(arrWorte(J, 2), _
"###,###,###") & vbCrLf
Next J
End With
'Tabelle generieren und sortieren
Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByTabs
If strSort = "W" Then 'nach Worten
Selection.Sort ExcludeHeader:=False, _
FieldNumber:="Spalte1", _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending, _
FieldNumber2:="Spalte2", _
SortFieldType2:=wdSortFieldNumeric, _
SortOrder2:=wdSortOrderAscending, _
Separator:=wdSortSeparateByTabs, _
SortColumn:=False, _
CaseSensitive:=False, _
LanguageID:=wdLanguageNone
Else 'Nach Anzahl
Selection.Sort ExcludeHeader:=False, _
FieldNumber:="Spalte2", _
SortFieldType:=wdSortFieldNumeric, _
SortOrder:=wdSortOrderDescending, _
FieldNumber2:="Spalte1", _
SortFieldType2:=wdSortFieldAlphanumeric, _
SortOrder2:=wdSortOrderAscending, _
Separator:=wdSortSeparateByTabs, _
SortColumn:=False, _
CaseSensitive:=False, _
LanguageID:=wdLanguageNone
End If
'Tabelle anpassen
Selection.Cells.HeightRule = wdRowHeightAuto
Selection.Cells.SetWidth _
ColumnWidth:=CentimetersToPoints(4), _
RulerStyle:=wdAdjustNone
Selection.Rows.SpaceBetweenColumns = _
CentimetersToPoints(0.25)

System.Cursor = wdCursorNormal
MsgBox "Fertig...", vbOKOnly + vbInformation

End Sub