title image


Smiley Re: Häufigkeit von Wörtern ermitteln
Hab da mal ein altes Teil ausgegraben (jetzt nur kurz getestet). Event. sollten versch. weitere Zeichen ausgenommen werden. Für Schleifen drum herum für mehrere Dok's gibt's u.a. hier zahlreiche Tipps / Code. Desgleichen (falls erforderlich) für andere als die Hauptdokumentkomponente.



' 12.11.01

Const ksTitel = "Wort-Häufigkeits-Statistik"

Const ksAbbruch = " - Drücken Sie zum Abbrechen "

Type tWords

Wort As String

ASCII As Integer

Anzahl As Long

Liste As String

End Type

Dim aWords() As tWords



Sub WortHäufigkeitsStatistik()

Dim oDoc As Document, nDoc As Document

Dim l As Long, lTotal As Long, lInList As Long

Dim sWord As String



' hier jetzt zunächst Abfragen wg. Dok-Schutz, mind. 1 Wort da etc.

If Documents.Count < 1 Then

MsgBox "Die Funktion kann nicht ausgeführt werden, da kein Dokument geöffnet ist!", vbExclamation, ksTitel

Exit Sub

End If

Set oDoc = ActiveDocument

If oDoc.ProtectionType = wdAllowOnlyComments Or oDoc.ProtectionType = wdAllowOnlyFormFields Then

MsgBox "Die Funktion kann nicht ausgeführt werden, da das Dokument geschützt ist!", vbExclamation, ksTitel

Exit Sub

End If

lTotal = oDoc.Words.Count

If lTotal <= 1 Then ' wg. Leer-Absatz = 1 Wort

MsgBox "Die Funktion kann nicht ausgeführt werden, da das Dokument kein Wort enthält!", vbExclamation, ksTitel

Exit Sub

End If



System.Cursor = wdCursorWait

ReDim Preserve aWords(0) ' Array initialisieren

For l = 1 To lTotal

sWord = Trim(oDoc.Words(l).Text)

' jetzt noch event. Steuerzeichen wie Absatzmarken ausschließen

If sWord = "" Then GoTo mNext

If Asc(sWord) < 32 Then GoTo mNext

StatusBar = ksTitel & ksAbbruch & ": Wort " & l & " von " & lTotal & " wird verarbeitet: " & sWord

lInList = flInList(sWord)

If lInList > 0 Then

' Anzahl erhöhen und Liste erweitern

aWords(lInList).Anzahl = aWords(lInList).Anzahl + 1

aWords(lInList).Liste = aWords(lInList).Liste & ", " & l

Else

' neu aufnehmen

lInList = UBound(aWords) + 1

ReDim Preserve aWords(lInList)

aWords(UBound(aWords)).Wort = sWord

aWords(UBound(aWords)).ASCII = Asc(sWord)

aWords(UBound(aWords)).Anzahl = 1

aWords(UBound(aWords)).Liste = l

End If

mNext:

Next l



If UBound(aWords) < 1 Then

MsgBox "Keine auswertbaren Wörter gefunden !", vbExclamation, ksTitel

Exit Sub

End If

' Ausgabe (hier in neues leeres Dok)

StatusBar = ksTitel & ": " & UBound(aWords) & " vorgefunden, Ausgabe nach " & ActiveDocument.Name & " erfolgt... "

Application.ScreenUpdating = False

Set nDoc = Documents.Add

Dim oRange As Range

Set oRange = nDoc.Range

' Titel

oRange.InsertAfter ksTitel & " von" & Chr(11) _

& oDoc.FullName & Chr(11) & "(" & lTotal & " Wörter Gesamt)" & vbCr

oRange.Paragraphs(1).Style = wdStyleTitle

' Überschriftszeile

oRange.InsertAfter "Wort" & vbTab & "ASCII 1" & vbTab _

& "Vorkommen" & vbTab & "Wortliste" & vbCr

For l = 1 To UBound(aWords)

oRange.InsertAfter aWords(l).Wort & vbTab _

& aWords(l).ASCII & vbTab _

& aWords(l).Anzahl & vbTab _

& aWords(l).Liste & vbCr

Next l



' einfache Tabelle erstellen (mit AutoFormat)

Set oRange = nDoc.Range(Start:=nDoc.Paragraphs(2).Range.Start, _

End:=nDoc.Paragraphs(nDoc.Paragraphs.Count - 1).Range.End)

oRange.ConvertToTable Separator:=wdSeparateByTabs, Format:=wdTableFormatProfessional, AutoFit:=True

Dim oTable As Table, oColumn As Column

Set oTable = nDoc.Tables(1)

With oTable

' Nummerierungsspalte hinzufügen

Set oColumn = .Columns.Add(oTable.Columns(1))

oColumn.Select

Set oRange = Selection.Range

oRange.Start = oColumn.Cells(2).Range.Start

oRange.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _

wdNumberGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _

wdListApplyToWholeList

.Cell(1, 1).Range.Text = "Lfd"

.Rows(1).HeadingFormat = True

.Sort True, 2 ' Sortierung nach Spalte "Wort"

.Columns.AutoFit

End With

Selection.Collapse

Application.ScreenUpdating = True

System.Cursor = wdCursorNormal

End Sub



Private Function flInList(sText As String) As Long

Dim l As Long

For l = 1 To UBound(aWords)

' CaseSenstitiv!

If aWords(l).Wort = sText Then

flInList = l

Exit Function

End If

Next l

End Function

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: