Option Explicit
Private Type myWorteStatistik_structure
s_Wort As String
l_cnt As Long
End Type
Private Const c_GROSSKLEINSCHREIBUNG_BEACHTEN As Boolean = False
Private Const c_WORT_MIMIMAL_LAENGE = 2
Private Const c_BINDESTRICHERSATZ = xxyyzzbbbzzyyxx
'************************************************************
Sub Word_StatistikWorte()
'************************************************************
' Zählt die Worte des aktiven Dokuments.
' Erzeugt ein temporäres Dokument und gibt darauf ein Tabelle
' mit den Spalten->Wort' und Häufigkeit aus
'
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
' !!! geschützter Bindestrich und Bindestrich werden vor der Zählung durch
' !!! c_BINDESTRICHERSATZ ersetzt, da Word diese sonst als zwei Worte betrachtet.
' !!! Nach der Zählung wird diese Ersetzung wieder korrigiert
' !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
Dim doc_org As Document, doc As Document, mytab As Table, myword As Variant
Dim f() As myWorteStatistik_structure, f_cnt As Long
Dim s_Wort As String
Dim l_Anz As Long, l_ind As Long, x As Long, pos As Long
Set doc_org = ActiveDocument
Application.ScreenUpdating = False
->erstmal eine Text-Kopie vom Original anlegen -> keine Tabellen mehr
Set doc = Documents.Add
doc.Content.Text = doc_org.Content.Text
->im Dokument alle Steuerzeichen durch Leerzeichen ersetzen
Call SteuerZeichenDurchLeerzeichenErsetzen(doc.Content)
->alle Worte abarbeiten
f_cnt = 0: ReDim Preserve f(1 To 1)
For Each myword In doc.Words
s_Wort = myword
s_Wort = Trim(s_Wort)
->Minimallänge ?
If Len(s_Wort) < c_WORT_MIMIMAL_LAENGE Then GoTo NAECHSTESWORT
->GroßKleinschreibung beachten ?
If Not c_GROSSKLEINSCHREIBUNG_BEACHTEN Then s_Wort = LCase(s_Wort)
->Wort suchen
l_ind = 0
For x = 1 To f_cnt
If s_Wort = f(x).s_Wort Then l_ind = x: Exit For
Next
->Wort schon vorhanden
If l_ind > 0 Then
->schon vorhanden -> Zähler erhöhen
f(l_ind).l_cnt = f(l_ind).l_cnt + 1
Else
->nicht vorhanden -> neu anlegen
f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
f(f_cnt).l_cnt = 1: f(f_cnt).s_Wort = s_Wort
End If
NAECHSTESWORT:
Next
->temporäre Kopie schliessen
doc.Close Savechanges:=False
Application.ScreenUpdating = True
->neues Dokument anlegen
Set doc = Documents.Add
doc.Content.Text =
Selection.InsertAfter Statistik Wortanzahl Datei: & doc.Name & vbCr & vbCr
Selection.Collapse direction:=wdCollapseEnd
->Tabelle einfügen
Set mytab = doc.Tables.Add(Range:=Selection.Range, NumRows:=f_cnt + 1, NumColumns:=2)
With mytab.Cell(1, 1).Range: .Text = Wort: .Bold = True: End With
With mytab.Cell(1, 2).Range: .Text = Anzahl: .Bold = True: End With
For x = 1 To f_cnt
s_Wort = f(x).s_Wort
Do
pos = InStr(1, s_Wort, c_BINDESTRICHERSATZ)
If pos = 0 Then Exit Do
->BINDESTRICHERSATZ durchBindestrich ersetzen
s_Wort = Left(s_Wort, pos - 1) & Chr(30) & _
Right(s_Wort, Len(s_Wort) - pos + 1 - Len(c_BINDESTRICHERSATZ))
Loop
mytab.Cell(x + 1, 1).Range.Text = s_Wort
mytab.Cell(x + 1, 2).Range.Text = f(x).l_cnt
Next
->Tabelle sortieren
mytab.Sort _
ExcludeHeader:=True, _
FieldNumber:=1, _
SortFieldType:=wdSortFieldAlphanumeric, _
SortOrder:=wdSortOrderAscending, _
CaseSensitive:=c_GROSSKLEINSCHREIBUNG_BEACHTEN
AUFRAEUMEN:
Set doc_org = Nothing: Set doc = Nothing: Set mytab = Nothing: Set myword = Nothing
End Sub
Private Function SteuerZeichenDurchLeerzeichenErsetzen(r As Range)
Dim x As Long
Call myErsetzen(r, Chr(30), c_BINDESTRICHERSATZ) ->geschützter Bindestrich -> c_BINDESTRICHERSATZ
Call myErsetzen(r, Chr(45), c_BINDESTRICHERSATZ) ->Bindestrich -> c_BINDESTRICHERSATZ
->Steuerzeichen durch Leerzeichen ersetzen
For x = 1 To 30
Call myErsetzen(r, Chr(x), ) 'Steuerzeichen (1 -30) -> Leerzeichen
Next
Call myErsetzen(r, Chr(31), ) 'bedingter Trennstrich -> löschen
Call myErsetzen(r, Chr(151), ) ->Langer Gedankenstrich -> löschen
Call myErsetzen(r, Chr(150), ) ->Gedankenstrich -> löschen
Call myErsetzen(r, Chr(160), ) 'geschütztes Leerzeichen -> Leerzeichen
Call myErsetzen(r, Chr(182), ) 'Absatz -> Leerzeichen
Call myErsetzen(r, Chr(133), ) 'Auslasspunkte -> Leerzeichen
Call myErsetzen(r, Chr(145), ) 'einf. öffnendes Anfz. -> Leerzeichen
Call myErsetzen(r, Chr(146), ) 'einf. schliessendes Anfz. -> Leerzeichen
Call myErsetzen(r, Chr(147), ) ' öffnendes Anfz. -> Leerzeichen
Call myErsetzen(r, Chr(148), ) ' schliessendes Anfz. -> Leerzeichen
For x = 10 To 2 Step -1
Call myErsetzen(r, String(x, ), ) ->doppelte Leerzeichen -> Leerzeichen
Next
End Function
Private Function myErsetzen(r As Range, s_Text As String, s_Ersetzen As String)
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With r.Find
.Text = s_Text: .Replacement.Text = s_Ersetzen: .Wrap = wdFindContinue: .Format = False
End With
r.Find.Execute Replace:=wdReplaceAll
End Function
