VBA: Suche Word Docs nach Wörtern
09.04.2020 17:57:25
Robin
heute geht es bei mir um ein Problem was mich schon seit Tagen beschäftigt und wozu ich bereits erfolglos englisch und deutschsprachige Foren durchsucht habe.
Ich möchte in einem definierten Ordner die Dateien nach einen bestimmten Begriff durchsuchen. Wenn das Wort gefunden wird soll es in die Zelle geschrieben werden, der dazugehörige Pfad soll in der Nachbarspalte stehen. Alle Dokumente wo das Wort nicht gefunden wird, sollen in einer anderen Spalte aufgeführt werden.
Das war nach etwas Arbeit kein Problem.
Ich suche derzeit nach einer Möglichkeit, dass gleichzeitig nach einen zweiten Begriff gesucht werden soll. Wenn eins der beiden Wörter auftaucht (also als ODER zu verstehen) soll das Dokument aufgelistet werden. Dokumente wo beide Wörter nicht aufgefunden werden, sollen in einer anderen Spalte auflistet werden. Ich habe versucht mit einer zweiten If Schleife dies zu Lösen, leider ohne Erolg.
Mein bisheriger Ansatz sieht wiefolgt aus:
--------------------------------------------
Sub GetDocData()
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, WkSht As Worksheet
Dim strFolder As String, strFile As String, r As Long, n As Long, s As Long
strFolder = GetFolder
If strFolder = "" Then Exit Sub
Set WkSht = ActiveSheet
r = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row 'r Wort 1
n = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row 'n Ausschuss
s = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row 's Wort 2
wdApp.WordBasic.DisableAutoMacros
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, _
Visible:=False)
With wdDoc 'Loop 1 Wort 1
With .Range.Find 'Wort 1
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = WkSht.Cells(1, 1).Text
'.Text = WkSht.Cells(2, 1).Text
.Execute
If .Found = True Then
r = r + 1
WkSht.Cells(r, 1) = strFile
WkSht.Cells(r, 2) = strFolder
Else:
With .Range.Find 'Startet Loop Wort 2
.ClearFormatting
.Replacement.ClearFormatting
.MatchWholeWord = True
.MatchCase = True
.Wrap = wdFindStop
.Text = WkSht.Cells(2, 1).Text
.Execute
If .Found = True Then
s = s + 1
WkSht.Cells(s, 3) = strFile
WkSht.Cells(s, 4) = strFolder
Else: 'Wenn Beide Wörter nicht gefunden
n = n + 1
WkSht.Cells(n, 5) = strFile
WkSht.Cells(n, 6) = strFolder
'Kill (wdDoc) eigener Macro
End If 'Loop 2
End With 'End With Loop2
End If 'Loop 1
End With 'End With Loop 1
.Close SaveChanges:=False
End With 'End With Doc
strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
--------------------------------------------------------------
Beim Starten kommt die Meldung für das "With.Range.Find 'Startet Looü Wort 2", dass das Objekt oder die Methode nicht gefunden wird.
Ohne die Zeile Läuft das Makro, aber er findet kein Ergbenisse für das 2. Wort.
Vielleicht kennt einer von euch eine Lösung.
Es darf auch ein anderer Ansatz sein wie man einen 2. Suchbegriff in die Funktion einbettet. Ebenfalls funktionierten "Or" oder einfach einer 2. Zeile ".Text=.." in der ersten Schleife nicht.
Falls Euch der Code zu unübersichtlich ist, kann ich den Orginalen, ohne 2. If Schleife auch geben.
Vielen Dank schon mal
BG