Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1156to1160
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Wörter in einem Bereich zählen, VBA

Wörter in einem Bereich zählen, VBA
simo
hallo zusammen,
ich habe im forum hier den unten angehängten code gefunden, welcher eine spalte nach wörtern durchsucht, sie zählt und dann ausgibt.
für meine anwendung wäre es sinnvoll, diese funktion auf einen bereich auszuweiten, bsp. A1 : D10
ich habe gerade schon eine weile herumprobiert, aber ich schaffe es leider nicht. vielleicht hat ja jemand eine schnelle idee.
vielen dank im voraus!

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
Range(Cells(1, 6), Cells(dicAlle.Count, 6)) = WorksheetFunction.Transpose(dicAlle.keys)
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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Wörter in einem Bereich zählen, VBA
28.05.2010 00:54:26
fcs
Hallo Simo,
hier eine angepasste Version.
Die Werte für Zeile1, Spalte1, Spalte2 und lngLZ muss du ggf. ändern.
Gruß
Franz
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
Dim Bereich As Range, Zelle As Range
Dim Spalte1 As Long, Spalte2 As Long, Zeile1 As Long
'Bereich mit zu zählenden Wörtern
Spalte1 = 1 '1. Splate - Spalte A
Spalte2 = 4 'letzte Spalte - Spalte D
Zeile1 = 1 ' 1. Zeile des datenbereichs
'letzte Zeile in den Spalten
For i = Spalte1 To Spalte2
lngLZ = Application.WorksheetFunction.Max(lngLZ, _
Cells(Rows.Count, i).End(xlUp).Row)
Next i
Set Bereich = Range(Cells(Zeile1, Spalte1), Cells(lngLZ, Spalte2))
'Texte einlesen
'Dictionary erstellen und zuweisen
Set dicAlle = CreateObject("Scripting.Dictionary")
For Each Zelle In Bereich
If Not IsEmpty(Zelle) Then
'Aufteilung der Zelltexte in einzelne Array
arrVarEinzelzelle = Split(Textsäubern(Zelle.Text))
'Zuweisung der Wörter zum Dictionary
For j = 0 To UBound(arrVarEinzelzelle, 1)
dicAlle(arrVarEinzelzelle(j)) = dicAlle(arrVarEinzelzelle(j)) + 1
Next j
End If
Next Zelle
'Ausgabe der Ergebnisse
Range("f:g").ClearContents
Range(Cells(1, 6), Cells(dicAlle.Count, 6)) = WorksheetFunction.Transpose(dicAlle.keys)
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, ";", " ")
'doppelte Leerzeichen löschen
Do Until InStr(1, strÜbergabe, "  ") = 0
strÜbergabe = Replace(strÜbergabe, "  ", " ")
Loop
'alle Zeichen in Kleinbuchstaben wandeln
Textsäubern = Trim(LCase(strÜbergabe))
End Function

Anzeige

324 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige