Excel Wörterbuch: in Word-Datei suchen und zählen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Excel Wörterbuch: in Word-Datei suchen und zählen
von: Dylan Knörr
Geschrieben am: 25.09.2015 16:07:24

Hallo liebe Excel-Freunde,
für eine Inhaltsanalyse möchte ich ein Worddokument mithilfe eines Excel-Wörterbuchs durchsuchen, die Treffer einfärben, zählen und den jeweiligen Fundort samt Trefferanzahl je Wort in das Excel-Wörterbuch schreiben, bspw. in Spalte B und C.
Bisher ist es mir mithilfe diverser Codeschnipsel und Anpassungen nur gelungen, die Treffer einzufärben und zu zählen, siehe hierzu unten stehender Code. Vor allem dauert das Ausführen des Skriptes bei meinem 4000-Seiten-Dokument fast eine Viertelstunde... ist das normal?
Könnt ihr mir bitte weiterhelfen?
Vielen Dank!

Sub KEYWORDS_SUCHEN_UND_ZAEHLEN()
'
' KEYWORDS SUCHEN
' UND FARBIG HERVORHEBEN
'
Dim myRange As Range, AktWord As Variant
Dim AllWord() As String, iWord As Long, Found As Boolean
Dim TmpStr As String
Set myRange = ActiveDocument.Range
'
' Exceldaten aus offener Arbeitsmappe einlesen
' Aktuell: 1. Spalte Zeile 1-200
'
Dim xlApp As Object ' Excel.Application
Dim SuchRange As Object, AktZelle As Object
Set xlApp = GetObject(, "Excel.Application")
Set SuchRange = xlApp.Range("A1:A200")
With SuchRange
 For Each AktZelle In SuchRange
   If Len(AktZelle & "") > 0 Then
     ReDim Preserve AllWord(iWord)
     AllWord(iWord) = UCase(AktZelle)
     iWord = iWord + 1
   End If
 Next
End With
'
' Worddokument durchsuchen und Wörter Rot färben
'
Set myRange = ActiveDocument.Range
With myRange
 For Each AktWord In .Words
   TmpStr = Trim(AktWord.Text)
   For iWord = 0 To UBound(AllWord)
     If UCase(TmpStr) Like AllWord(iWord) & "*" Then
        AktWord.Font.Color = wdColorRed
     End If
   Next
 Next
End With
Set SuchRange = Nothing
Set myRange = Nothing
'
' FARBIG HERVORGEHOBENE
' KEYWORDS ZÄHLEN
'
Dim highlightCount
highlightCount = 0
For Each w In ActiveDocument.Words
    If w.Font.Color = wdColorRed Then
        'w.Delete
        highlightCount = highlightCount + 1
    End If
Next
MsgBox ("Das Dokument enthält " & highlightCount & " Übereinstimmungen mit dem Wörterbuch.")
End Sub

Bild

Betrifft: AW: Excel Wörterbuch: in Word-Datei suchen und zählen
von: Sepp
Geschrieben am: 25.09.2015 17:49:54
Hallo Dylan,
teste mal.

Sub KEYWORDS_SUCHEN_UND_ZAEHLEN()
  '
  ' KEYWORDS SUCHEN
  ' UND FARBIG HERVORHEBEN
  '
  Dim myRange As Range, AktWord As Variant
  Dim objArrayList As Object, vntList As Variant
  Dim xlApp As Object ' Excel.Application
  Dim lngR As Long, lngC As Long, lngCount As Long
  
  Set myRange = ActiveDocument.Range
  Set xlApp = GetObject(, "Excel.Application")
  Set objArrayList = CreateObject("System.Collections.Arraylist")
  '
  ' Exceldaten aus offener Arbeitsmappe einlesen
  ' Aktuell: 1. Spalte Zeile 1-200
  '
  vntList = xlApp.Range("A1:A200")
  
  With objArrayList
    For lngR = LBound(vntList, 1) To UBound(vntList, 1)
      For lngC = LBound(vntList, 2) To UBound(vntList, 2)
        If Trim(vntList(lngR, lngC)) <> "" Then
          If Not .Contains(Trim(LCase(vntList(lngR, lngC)))) Then
            If vntList(lngR, lngC) <> "" Then .Add Trim(LCase(vntList(lngR, lngC)))
          End If
        End If
      Next
    Next
  End With
  
  '
  ' Worddokument durchsuchen und Wörter Rot färben
  '
  
  With myRange
    For Each AktWord In .Words
      If objArrayList.Contains(Trim(LCase(AktWord.Text))) Then
        AktWord.Font.Color = wdColorRed
        lngCount = lngCount + 1
      End If
    Next
  End With
  
  MsgBox ("Das Dokument enthält " & lngCount & " Übereinstimmungen mit dem Wörterbuch.")
  
  Set objArrayList = Nothing
  Set xlApp = Nothing
  Set myRange = Nothing
End Sub


Gruß Sepp


Bild

Betrifft: AW: Excel Wörterbuch: in Word-Datei suchen und zählen
von: Dylan Knörr
Geschrieben am: 27.09.2015 15:38:27
Lieber Sepp,
vielen Dank für Deine schnelle Antwort!
Allerdings liefert Dein Skript exakt das gleiche Ergebnis zur gleichen Geschwindigkeit wie mein Skript.
Welche Funktion noch fehlt (siehe oben):
- jeweiligen Fundort samt Trefferanzahl je Wort in das Excel-Wörterbuch schreiben, bspw. in Spalte B und C
Herzliche Grüße,
Dylan

Bild

Betrifft: AW: Excel Wörterbuch: in Word-Datei suchen und zählen
von: Born
Geschrieben am: 28.09.2015 13:24:18
Hallo Dylan,
um es etwas schneller auszuführen, kannst Du noch am Start des Makros
ScreenUpdating, EnableEvents und DisplayAlerts auf False setzen sowie den Calculationmodus auf Manuell. Am Ende des Makros setzt Du alles wieder zurück.
Viele Grüße,
M. Born

Bild

Betrifft: AW: Excel Wörterbuch: in Word-Datei suchen und zählen
von: Dylan Knörr
Geschrieben am: 28.09.2015 19:38:50
Lieber M. Born,
auch Dir vielen Dank für Deine schnelle Nachricht!
ScreenUpdating und DisplayAlerts funktionieren (ich arbeite in Word und führe dort auch das Makro aus), EnableEvents und Calculation leider nicht. Dies hat daher die Laufzeit leider entsprechend wenig verkürzt.
Die Wartezeit nehme ich ja in Kauf, wenn meine übrigen und deutlich wichtigeren Probleme beseitigt sind (wie bereits geschildert):
- Trefferanzahl pro Wort aus dem Wörterbuch in die Spalte B des Excel-Wörterbuchs schreiben
- Fundort (Seite) pro Wort aus dem Wörterbuch in die Spalte C des Excel-Wörterbuchs schreiben
Ich komme da leider überhaupt nicht weiter :(
Herzliche Grüße,
Dylan

Bild

Betrifft: AW: Excel Wörterbuch: in Word-Datei suchen und zählen
von: Dylan Knörr
Geschrieben am: 29.09.2015 17:47:01
Kann mir denn niemand mit dem Problem hier helfen?

Bild

Betrifft: leicht angepaßt
von: Michael
Geschrieben am: 29.09.2015 18:21:07
Hi zusammen,
ich habe Sepps Code etwas umgestellt:
a) kenne ich mich mit der arraylist nicht aus, und bevor ich lange herumsuche, habe ich dictionary verwendet
b) da werden die gefundenen Wörter der Spalte A (ohne etwaige Doppelte) als "key" gespeichert und als "item" die Zeilennr.
c) als Array werden die Spalten A-C eingelesen, wobei B & C gleich geleert werden
d) wenn ein Wort im Dictionary gefunden wurde, wird die Anzahl im Array/Spalte B erhöht, in Spalte C wird die Spalte/Zeile des Word-Docs geschrieben.
e) das ganze Array wird in Excel zurückgeschrieben.
Teste mal:

Option Explicit
Sub KEYWORDS_SUCHEN_UND_ZAEHLEN_DIC()
  '
  ' KEYWORDS SUCHEN
  ' UND FARBIG HERVORHEBEN
  '
  Dim myRange As Range, AktWord As Variant
  Dim objArrayList As Object, vntList As Variant
  Dim xlApp As Object ' Excel.Application
  Dim lngR As Long, lngC As Long, lngCount As Long
  Dim begriff As String
  Set myRange = ActiveDocument.Range
  Set xlApp = GetObject(, "Excel.Application")
  'Set objArrayList = CreateObject("System.Collections.Arraylist")
  
  Set objArrayList = CreateObject("scripting.dictionary")
  '
  ' Exceldaten aus offener Arbeitsmappe einlesen
  ' Aktuell: 1. Spalte Zeile 1-200
  '
  vntList = xlApp.Range("A1:C200")
  ' Spalte B auf 0 setzen, Spalte C = Leerstring
  For lngR = LBound(vntList, 1) To UBound(vntList, 1)
    If vntList(lngR, 1) <> "" Then _
       objArrayList(Trim(LTrim(LCase(vntList(lngR, 1))))) = lngR
    vntList(lngR, 2) = 0
    vntList(lngR, 3) = ""
  Next
  ' Worddokument durchsuchen und Wörter Rot färben
  
  With myRange
    For Each AktWord In .Words
      begriff = Trim(LTrim(LCase(AktWord.Text)))
      If objArrayList.Exists(begriff) Then
        AktWord.Font.Color = wdColorRed
        lngR = objArrayList.Item(begriff)
        vntList(lngR, 2) = vntList(lngR, 2) + 1
        vntList(lngR, 3) = vntList(lngR, 3) & "s" & _
           AktWord.Information(wdFirstCharacterColumnNumber) & _
           "r" & AktWord.Information(wdFirstCharacterLineNumber) & ";"
        lngCount = lngCount + 1
      End If
    Next
  End With
  xlApp.Range("A1:C200") = vntList
  
  MsgBox ("Das Dokument enthält " & lngCount & " Übereinstimmungen mit dem Wörterbuch.")
  
  Set objArrayList = Nothing
  Set xlApp = Nothing
  Set myRange = Nothing
End Sub
Schöne Grüße,
Michael
P.S.: Sehr schöne Blindtexte gibt es übrigens bei http://bavaria-ipsum.de/
Das erste Wort zum Testen war natürlich "Maß", denn man Prost!

Bild

Betrifft: AW: leicht angepaßt
von: Dylan Knörr
Geschrieben am: 29.09.2015 23:33:24
Vielen lieben Dank, Michael!
Nachdem gestern mein Rechner den Geist aufgegeben hat, muss ich jetzt alles auf dem Surface testen :(
Das Skript sucht jetzt fleißig nach den Wörtern im Wörterbuch, markiert die Treffer im Worddokument und gibt entsprechende Trefferzahlen und -orte je Wort in Excel aus.
Allerdings scheint etwas mit den Daten in Excel nicht zu stimmen: Wenn ich stichprobenartig in Word nach ein paar Wörtern suche, werden auf diese Weise oft mehr Treffer gefunden als Excel in der Spalte B als Zahl ausgibt. Könnte das daran liegen, dass die herkömmliche Word-Suche automatisch mit Wildcard sucht und Excel nicht? Wenn ich bspw. nach "AKW" über die Suchmaske suche, finde ich Wörter wie "AKW", "AKW-Betreiber" und "AKWs". Excel findet allerdings nur die ersten beiden und ignoriert den letzten.
Darüber hinaus verstehe ich den Fundort in Spalte C nicht ganz: Werden dort nun die jeweiligen Fundstellen der Wörter aus dem in Excel hineingeladenen Array angegeben? Ich brauche nämlich lediglich die Seitenangabe der jeweiligen Fundstelle im Worddokument...
Nochmals Danke für Deine Mühe und herzliche Grüße,
Dylan

Bild

Betrifft: Salamitaktik
von: Michael
Geschrieben am: 30.09.2015 16:47:40
Hi Dylan,
Du führst uns hier ein schönes Beispiel von Salamitaktik vor: sobald was tut, fällt Dir ein, daß es eigentlich was anderes tun soll. Zur Verdeutlichung: nachdem ich mit Word-VBA völlig unbeleckt bin, habe ich gestern erst mal 1 1/2 h recherchiert, wie man die Zeile ermittelt, und jetzt sagst Du, daß Du sie gar nicht willst: wenn Du die Seiten-Nr. haben willst, sieh Dir die Parameter von AktWord.Information an, da wirst Du sicher fündig.
Jetzt kriegst Du es natürlich ab, stellvertretend für viele andere, mach Dir nix draus. Aber: es wäre einfacher, wenn man gleich *alles* wüßte.
Die Word-Schleife läuft alle Wörter der Reihe nach durch: myRange ist der komplette Text, von dem jeweils eines nach dem anderen, nämlich AktWord betrachtet wird.
Ich habe gestern aufgeschnappt, daß Satzzeichen von Word als "eigenständige" Objekte interpretiert werden: das erklärt, warum AKW-Betreiber gefunden wird: dabei werden nämlich *drei* "Wörter" verglichen: "AKW", "-" und "Betreiber".
Eine Wildcard-Suche (akw*) ist im Dictionary nicht direkt verfügbar,
http://stackoverflow.com/questions/28246074/wildcard-search-of-dictionary
so daß man prinzipiell alle Wörter in einer Schleife durchgehen muß (das ist der Schnipsel ganz unten).
Klingt zeitaufwendig und nach komplett falschem Ansatz.
Der richtige wäre wahrscheinlich (mal ins Blaue gesagt), nicht alle einzelnen Wörter des Textes durchzulaufen, sondern die von Excel übernommenen Werte der Reihe in Words Suchfunktion zu übernehmen und von dort aus die Trefferausgabe zu steuern.
Ich habe jetzt trotzdem aus reiner Faulheit die "falsche" Variante entsprechend erweitert:

Option Explicit
Sub KEYWORDS_SUCHEN_UND_ZAEHLEN_DIC_Wild()
  Dim myRange As Range, AktWord As Variant, AktKey As Variant
  Dim objArrayList As Object, vntList As Variant
  Dim xlApp As Object ' Excel.Application
  Dim lngR As Long, lngC As Long, lngCount As Long
  Dim begriff As String
  Dim gefunden As Boolean
  
  Set myRange = ActiveDocument.Range
  Set xlApp = GetObject(, "Excel.Application")
  Set objArrayList = CreateObject("scripting.dictionary")
  
  vntList = xlApp.Range("A1:C200")
  ' Spalte B auf 0 setzen, Spalte C = Leerstring
  For lngR = LBound(vntList, 1) To UBound(vntList, 1)
    If vntList(lngR, 1) <> "" Then _
       objArrayList(Trim(LTrim(LCase(vntList(lngR, 1))))) = lngR
    vntList(lngR, 2) = 0
    vntList(lngR, 3) = ""
  Next
  ' Worddokument durchsuchen und Wörter Rot färben
  
  With myRange
    For Each AktWord In .Words
      begriff = Trim(LTrim(LCase(AktWord.Text)))
      For Each AktKey In objArrayList.keys
        If begriff Like "*" & AktKey & "*" Then
         AktWord.Font.Color = wdColorRed
         lngR = objArrayList.Item(AktKey)
         vntList(lngR, 2) = vntList(lngR, 2) + 1
         vntList(lngR, 3) = vntList(lngR, 3) & _
            "s" & AktWord.Information(wdFirstCharacterColumnNumber) & _
            "r" & AktWord.Information(wdFirstCharacterLineNumber) & _
            "S" & AktWord.Information(wdActiveEndPageNumber) & ";"
         ' ********** s=spalte, r=zeile,S=Seite *******************
         lngCount = lngCount + 1
         Exit For
        End If
      Next
    Next
  End With
  xlApp.Range("A1:C200") = vntList
  
  MsgBox ("Das Dokument enthält " & lngCount & " Übereinstimmungen mit dem Wörterbuch.")
  
  Set objArrayList = Nothing
  Set xlApp = Nothing
  Set myRange = Nothing
End Sub

Die braucht bei 1450 Wörtern und 16 Suchbegriffen schon ein paar Sekunden. Spiel halt mal damit herum, ob Du dem Code vertraust, und wenn ja, wirf ihn an und geh mit dem Hund spazieren...
Schöne Grüße,
Michael

Bild

Betrifft: AW: Salamitaktik
von: Dylan Knörr
Geschrieben am: 30.09.2015 20:23:03
Lieber Michael,
herzlichen Dank für die Zeit und Mühe, die Du investiert hast.
Ich weiß Dein Engagement sehr zu schätzen!
Außerdem verstehe ich, dass es nervig ist, wenn immer wieder neue und andere Aspekte erfragt werden; im Hinblick auf die Validität der Daten (Thema Wildcard) hast Du auch vollkommen Recht. Das ist mir leider erst beim Ausprobieren aufgefallen. Allerdings muss ich zu meiner "Verteidigung" sagen, dass bspw. hinsichtlich des Fundorts meinerseits nie die Rede von Zeilen und Spalten, sondern ausschließlich von Seiten war (siehe mein Post vom 28.9.).
Wie dem auch sei: Dein Code funktioniert genau so, wie ich es mir gewünscht habe und selbst nicht hinbekommen hätte. Nochmals vielen Dank!
Womit kann ich Dir denn eine Freude machen bzw. in welcher Form kann ich mich bei Dir revanchieren?
Herzliche Grüße und einen schönen Abend,
Dylan

Bild

Betrifft: Alles gut
von: Michael
Geschrieben am: 01.10.2015 14:55:49
Lieber Dylan,
das mit den Seitenzahlen habe ich übersehen, entschuldigung, daß ich deshalb gemeckert habe.
Aber vielleicht war's ganz gut so, irgendwie mußte ich ja dieses ".Information" finden, und wenn man das mal hat, ist es nicht mehr schwierig, das eine (Zeilen) oder andere (Seiten) zu ermitteln.
Es hat mich interessiert, Deine Aufgabe zu bearbeiten, gerade weil ich von Word VBA keinen Schimmer habe: es ging ja nur darum, Sepps vorhandenen Code-Schnipsel anzupassen.
Insbesondere wollte ich schon sein einiger Zeit mal Wörter in einem Text zählen. Das konnte ich jetzt easy aus der vorhandenen Lösung ableiten:

Sub Woerter_Zaehlen()
  Dim myRange As Range, AktWord As Variant, AktKey As Variant
  Dim objArrayList As Object, vntList As Variant
  Dim xlApp As Object ' Excel.Application
  Dim lngR As Long, lngC As Long, lngCount As Long
  Dim begriff As String
  Dim gefunden As Boolean
  Dim t1 As Single, t2 As Single
  Set myRange = ActiveDocument.Range
  Set xlApp = GetObject(, "Excel.Application")
  Set objArrayList = CreateObject("scripting.dictionary")
  t1 = Timer
  vntList = xlApp.Range("A1:B200")
 
  With myRange
    For Each AktWord In .Words
      begriff = Trim(LTrim(LCase(AktWord.Text)))
' ********************** Variante 1: nur zählen ********************
'      If objArrayList.Exists(begriff) Then
'         objArrayList.Item(begriff) = objArrayList.Item(begriff) + 1
'        Else
'         objArrayList(begriff) = 1
'      End If
' ********** benötigt nur wenige Sekunden **************************
' ********************** Variante 2: mit Seitenzahlen **************
      If objArrayList.Exists(begriff) Then
         objArrayList.Item(begriff) = objArrayList.Item(begriff) & _
         "S" & AktWord.Information(wdActiveEndPageNumber)
        Else
         objArrayList(begriff) = "S" & _
            AktWord.Information(wdActiveEndPageNumber)
      End If
' *********** benötigt die ca. 20-fache Zeit ***********************
    Next
  End With
  lngR = 1
  lngCount = objArrayList.Count
  ReDim vntList(1 To lngCount + 1, 1 To 2)
  For Each AktKey In objArrayList.keys
    vntList(lngR, 1) = AktKey
    vntList(lngR, 2) = objArrayList.Item(AktKey)
    lngR = lngR + 1
  Next
  ' zeit ans Array anhängen
  t2 = Timer
  vntList(lngCount + 1, 1) = t1
  vntList(lngCount + 1, 2) = t2
  ' ********************** Variante 1: nur zählen ********************
'  xlApp.Range("A1:B" & lngCount + 1) = vntList
  ' ********************** Variante 2: mit Seitenzahlen **************
  xlApp.Range("E1:F" & lngCount + 1) = vntList
  
  MsgBox "t1: " & t1 & " t2: " & t2
  Set objArrayList = Nothing
  Set xlApp = Nothing
  Set myRange = Nothing
End Sub

Eine Rotfärbung ist hier natürlich sinnlos.
Das "der" ist im geprüften Text mit 9000 Wörtern am häufigsten, dicht gefolgt von "und" und "die", außerdem kann man bei der Ausgabe schön nachvollziehen, wie Word-VBA arbeitet: massenweise Leerzeichen und alle Sonderzeichen werden getrennt erfaßt bzw. ausgegeben.
Also haben wir die typische win-win-Situation: durch die Lösung Deines Problems hat sich auch meines gelöst.
Dank auch an Sepp für die Vorarbeit.
Herzliche Grüße aus Nürnberg,
Michael

Bild

Betrifft: AW: Alles gut
von: Dylan Knörr
Geschrieben am: 01.10.2015 17:15:37
Das freut mich sehr! :)
Dein Wörterzählcode sieht übrigens interessant aus. Gab es dazu einen bestimmten Anlass oder einfach nur das Interesse, ob und wie so etwas funktioniert? Der Ansatz ist nämlich für eine quantitative Inhaltsanalyse sehr hilfreich!
Ich bin auf jeden Fall als Nicht-Programmierer ziemlich stolz, dass ich nicht mit leeren Händen hier ins Forum gekommen bin und ich Dich (und Sepp) mit meiner Problemstellung begeistern konnte.
Herzliche Grüße aus dem Tal der Wupper und frohes Coden,
Dylan

Bild

Betrifft: AW: Alles gut
von: Michael
Geschrieben am: 03.10.2015 15:20:22
Hallo Dylan,
wie sag ich's Dir möglichst kurz?
Mir ging es darum, daß die Verschlüsselung eines Textes mit einem zufälligen Schlüssel, der im Prinzip genauso lang ist wie der Text, und mit dem letzterer XORiert wird, als sicher gilt, und zwar unter der Voraussetzung, daß nie mehrmals der gleiche Schlüssel verwendet wird: https://de.wikipedia.org/wiki/One-Time-Pad
Ansonsten *könnte* man aus zwei verschiedenen Texten den Schlüssel wieder extrahieren: dazu verwendet man nämlich die Wörter, die in der jeweiligen Sprache am häufigsten vorkommen (das schrittweise Verfahren habe ich bislang im Internet nicht so recht beispielhaft beschrieben gefunden, erst im Anhang von https://de.wikipedia.org/wiki/Geheime_Botschaften). Welche das in der jeweiligen Sprache sind, ist mehr oder weniger bekannt, aber ich wollte einfach mal einen "eigenen" Text analysieren.
Ich habe den Schnipsel nicht zuletzt deshalb hochgeladen, weil er evtl. auch für Dich tauglich wäre, falls Du auf die Einfärbung verzichten könntest: anschließend könnte man Dein vorhandenes Wörterbuch mit der Liste der gefundenen/gezählten Wörter vergleichen, was wahrscheinlich insgesamt schneller ist als die verschachtelten Schleifen - aber Du wirst ja nicht laufend 4000-seitenweise Texte vergleichen wollen.
Happy Exceling,
Michael

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Excel Wörterbuch: in Word-Datei suchen und zählen"