VBA: Word Dokumente nach Begriffen durchsuchen

[Drummer_LP]

Hallo Leute,
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:

Code:

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

[maninweb]

Hallo,

so wie ich das sehe, befindest Du Dich bereits in einem With, weshalb das zweite With dann wie .Range.Find.Range.Find wäre und somit nicht geht.
Versuche mal für das zweite With: With wdDoc.Range.Find

Gruß

[snb]

Code:

Sub M_snb()
  on error goto XL90:
  c00 = "G:\OF\"
  c01 = Dir(c00 & "*.docx")
  sn = Array("Wort1", "Wort2")
 
  Do Until c01 = ""
      With GetObject(c00 & c01)
        x = InStr(.Content, sn(0))
        y = InStr(.Content, sn(1))
        .Close -1
      End With
      c02 = c02 & "|" & c01 & "_" & sn(0) & ": " & x & "  " &  sn(1) & ": " & y
      c01=dir
    Loop

XL90:   
    st = Split(c02, "|")
    Cells(1).Resize(UBound(st)) = Application.Transpose(st)
End Sub