AW: Wörter zählen
02.01.2010 16:48:00
Peter
Hallo Wulf,
probiere bitte diesen Code...(nicht von mir sondern aus dem Forum)
Option Explicit
Sub Wörterzählen()
Dim dicAlle As Object
Dim arrZellworte As Variant
Dim arrVarAlleZellen() As Variant
Dim arrVarEinzelzelle As Variant
Dim lngLZ As Long, i As Long, j As Long
'letzte Zeile Spalte N
lngLZ = Cells(Rows.Count, 14).End(xlUp).Row
'Texte einlesen Spalte N
arrVarAlleZellen = Range(Cells(2, 14), Cells(lngLZ, 14))
'Dictionary erstellen und zuweisen
Set dicAlle = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arrVarAlleZellen)
'Aufteilung der Zelltexte in einzelne Array
arrVarEinzelzelle = Split(Textsäubern(arrVarAlleZellen(i, 1)))
'Zuweisung der Wörter zum Dictionary
For j = 0 To UBound(arrVarEinzelzelle, 1)
dicAlle(arrVarEinzelzelle(j)) = dicAlle(arrVarEinzelzelle(j)) + 1
Next j
Next i
'Ausgabe der Ergebnisse
Range("f:g").ClearContents
'Spalte B: Wörter
Range(Cells(1, 6), Cells(dicAlle.Count, 6)) = WorksheetFunction.Transpose(dicAlle.keys)
'Spalte B: Anzahl
Range(Cells(1, 7), Cells(dicAlle.Count, 7)) = WorksheetFunction.Transpose(dicAlle.items)
End Sub
Function Textsäubern(ByVal strÜbergabe As String) As String
'ersetzen ungewollter Zeichen, beliebig erweiterbar
strÜbergabe = Replace(strÜbergabe, Chr(13), " ")
strÜbergabe = Replace(strÜbergabe, Chr(10), " ")
strÜbergabe = Replace(strÜbergabe, "(", " ")
strÜbergabe = Replace(strÜbergabe, ")", " ")
strÜbergabe = Replace(strÜbergabe, ",", " ")
strÜbergabe = Replace(strÜbergabe, ".", " ")
strÜbergabe = Replace(strÜbergabe, ";", " ")
'alle Zeichen in Kleinbuchstaben wandeln
Textsäubern = LCase(strÜbergabe)
End Function
Gruß
Peter