Sub WortFrequenzZaehlen() ' ' WortFrequenzZaehlen Makro ' Makro erstellt am 08.06.2006 von Dr. Jürgen Aurich ' (Vermutlich nach Hinweisen von SmartTools) ' Const MaxWorte = 5000 ' Diese Zahl kann man bei Bedarf erhöhen. 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)) & 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