Forums Neueste Beiträge
 

Wort Statistik mit Seitenzahl

09/02/2009 - 10:36 von Oli | Report spam
Hallo,

ich suche eine Lösung die mir die Anzahl aller vorkommenden Wörter in einem
Worddokument (2003) einschließlich der Seitenzahl auf der die Worte
vorkommen ausgibt.

Ich habe einen VBA-Code gefunden der aber die dazügehörige Seitenzahl nicht
ausgibt (unten). VBA ist leider überhaupt nicht mein Ding ... kennt jemand
eine Lösung die auch die Seitenzahlen ausgibt auf denen die Worte
erscheinen?

Danke
Oli




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)) & 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
 

Lesen sie die antworten

#1 Costin Boldisor [MS]
25/02/2009 - 16:35 | Warnen spam
Hallo,

Ist Ihre Frage noch aktuell?

Vielen Dank,
Costin Boldisor | EMEA Support Specialist

"Oli" wrote in message
news:
Hallo,

ich suche eine Lösung die mir die Anzahl aller vorkommenden Wörter in
einem
Worddokument (2003) einschließlich der Seitenzahl auf der die Worte
vorkommen ausgibt.

Ich habe einen VBA-Code gefunden der aber die dazügehörige Seitenzahl
nicht
ausgibt (unten). VBA ist leider überhaupt nicht mein Ding ... kennt jemand
eine Lösung die auch die Seitenzahlen ausgibt auf denen die Worte
erscheinen?

Danke
Oli




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)) & 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


Ähnliche fragen