Sub WDFIDFWTF()
'
' basierend auf WortFrequenzZaehlen Makro
' Makro erstellt am 08.06.2006 von Dr. Jürgen Aurich
' (Vermutlich nach Hinweisen von SmartTools)
' ergänzt um zusätzliche Worte
' ergänzt um Highlight der Füllworte
' Überarbeitet von Ralf Seybold //www.seybold.de
'

' Definiere Wortliste für highlight
Dim listword() As Variant
listword() = Array("der", "hin", "jedes", "ist", "ihre", "bei", "unseren", "auch", "diesen", "wir", "sich", "von", "nach", "die", "das", "in", "auf", "unter", "und", "wo", "es", "unsere", "wie", "wer", "wann", "bei", "auf", "sie", "er", "auch", "denn", "für", "ihre", "uns", "an", "bis", "ihnen", "ihren", "deren", "ab", "als", "mit", "jede", "jeder")

' Worte aus Liste markieren und hervorheben
For Each Item In listword
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Highlight = True
    With Selection.Find
        .Text = Item
        .Replacement.Text = Item
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
Next
  Const MaxWorte = 500  ' Diese Zahl kann man bei Bedarf erhöhen.
  
' Selbe Füllworte nochmal definiert zum nicht zählen

  Const cstrAusschl = _
  "[der][die][das][ein][eine][einer][wer][wie][bis][ihnen][ihren][deren][ab][als][mit][jede][jeder][wir][sich][bei][diesen][diese]" & _
  "[was][wo][ist][und][oder][in][auf][es][unsere][wann][bei][er][sie][auch][denn][für][ihre][uns][an][von][nach][auch][unseren][hin][jedes][ist]"
  
  

  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 Problem...", _
               vbOKOnly + vbInformation, "!!! WDF IDF !!!"
        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)) & 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