Hallo liebe Community,

nachdem ich seit einigen Tagen nicht weiterkomme, wende ich mcih an euch.

Hintergrund:
Ich möchte ein automatisiertes Such-Kopier-Tool basteln, welches mehrere Wörter (siehe Datei, alle Wörter ab Spalte C15) nacheinander in Word sucht und falls es findet, einen Textausschnitt in Excel einfügt.

Ziel:
Pro Bereicht habe ich einen Reiter mit dem gefundenen Text und weitere Informationen. Er soll nur nach ganzen Worten suchen, nicht auf Klein- und Großschreibung achten und wenn es geht Punktuation (und am liebsten Leerzeichen) ignorieren.
Beispiel für Suchwort: "Richtig"
Folgende Wörter soll der Code beachten: "richtig", "Richtig", "Richtig.", "RICHTIG!", ("r i c h t i g")
Folgende Wörter soll der Coden NICHT beachten: "richtige", "Richtigstellung"


Jetziger Stand und Problem:
Alles klappt, bis auf dass die Suchfunktion kaum akkurat ist. Bedeutet, dass der Code manche Wörter nicht findet und folglich nciht rauskopiert, die in der Word Datei enhalten sind. Ich habe mich auch mit der Einstellung der zahlreichen Funktionen von Find.Execute auseinander gesetzt. Jedoch bin ich am verzweifeln. Ich kann nicht erkennen, ob es an den Einstellungen der Funktionen liegt, dass er mehrere Wörter sind oder irgendetwas mit der Schleife falsch ist.

Über jeden Tip freue ich mich sehr. Anbei die Datei und ein Beispielsdokument.
 

 Dateien:

Code: 

Sub Kopieren_von_Sinnabschnitten()
    Dim shtSearchItem As Worksheet
    Dim shtExtract As Worksheet
    Dim oWord As Word.Application
    Dim WordNotOpen As Boolean
    Dim oDoc As Word.Document
    Dim oRange As Word.Range
    Dim LastRow As Long
    Dim CurrRowShtSearchItem As Long
    Dim CurrRowShtExtract As Long
    Dim myPara As Long
    Dim myLine As Long
    Dim myPage As Long
    Dim oDocName As Variant
    Dim ncharacterbefore As Variant
    Dim ncharacterafter As Variant
    Dim xRange_searchterm As Range
    Dim xRange_searchterm2 As Range
    Dim LetzteG As Integer
    Dim LetzteSearch As Integer
    Dim Namee As Variant
    Dim NameSheet As Variant
    Dim i As Integer
    Dim y As Integer
    Dim a As Integer
    Dim r As Long
   
    
    
    On Error Resume Next
    
    Application.ScreenUpdating = False
    Set oWord = GetObject(, "Word.Application")
    If Err Then
        Set oWord = New Word.Application
        WordNotOpen = True
    End If
    On Error GoTo Err_Handler
    
    
    
    oWord.Visible = True
    oWord.Activate
    
    
    dataPath = Worksheets("Cockpit").Cells(5, 3).Value '<= modify according to your path
    dataFile = Dir(dataPath & "*.docx")
    
'--------Repeating Tesks for each Docucument ´begins here ------------------------------------------
    Do While dataFile <> vbNullString
    
        
        Set oDoc = oWord.Documents.Open(dataPath & dataFile)
        oDocName = oWord.ActiveDocument.Name
        
        Set shtSearchItem = ThisWorkbook.Worksheets("Cockpit")
        
        If ThisWorkbook.Worksheets.Count < 2 Then
            ThisWorkbook.Worksheets.Add After:=shtSearchItem
        End If
        
        Set shtExtract = ThisWorkbook.Worksheets(2)
        ThisWorkbook.Worksheets(2).Cells.ClearContents
        
        LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row
        Namee = oDocName
        ThisWorkbook.Worksheets(1).Cells(12, 3) = Namee
        ncharacterbefore = ThisWorkbook.Worksheets(1).Cells(8, 4)
        ncharacterafter = ThisWorkbook.Worksheets(1).Cells(9, 4) ' Sheet: Cockpit; Column: Characters
        NameSheet = Trim$(Left$(Worksheets("Cockpit").Cells(12, 3).Value, InStr(Worksheets("Cockpit").Cells(12, 3).Value, " ") + 1))
        
        shtExtract.Cells(1, 1).Value = "Suchbegriff"
        shtExtract.Cells(1, 2).Value = "Seite"
        shtExtract.Cells(1, 3).Value = "Berichtsname"
        shtExtract.Cells(1, 4).Value = "Ergebnisse"
            
        For CurrRowShtSearchItem = 15 To LastRow
            CurrRowShtExtract = 1
            
            
            Set oRange = oDoc.Range
            With oRange.Find
                .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 3).Text
    
                .MatchCase = False
                .MatchWholeWord = True
                '.IgnorePunct = True
                '.IgnoreSpace = True
                '.MatchWildcards = False
                '.MatchSoundsLike = False
                '.MatchAllWordForms = False

                '.Wrap = wdFindStop
                While .Execute = True
                    myPara = oDoc.Range(0, oRange.End).Paragraphs.Count
                    myPage = oRange.Information(wdActiveEndAdjustedPageNumber)
                    myLine = oRange.Information(wdFirstCharacterLineNumber)
                    
       
                    oRange.MoveStart wdCharacter, -ncharacterbefore
                    oRange.MoveEnd wdCharacter, ncharacterafter
                    
                    CurrRowShtExtract = CurrRowShtExtract + 1
    
                        shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
                        shtExtract.Cells(CurrRowShtExtract, 2).Value = myPage
                        shtExtract.Cells(CurrRowShtExtract, 3).Value = oDocName
                        shtExtract.Cells(CurrRowShtExtract, 4) = oRange.Text
                    
                        'shtExtract.Cells(CurrRowShtExtract, 1).Value = .Text
                        'shtExtract.Cells(CurrRowShtExtract, 2).Value = myPara
                        'shtExtract.Cells(CurrRowShtExtract, 3).Value = myPage
                        'shtExtract.Cells(CurrRowShtExtract, 4).Value = myLine
                        'shtExtract.Cells(CurrRowShtExtract, 5).Value = oDocName
                        'shtExtract.Cells(CurrRowShtExtract, 6) = oRange.Text
                        
                    
                    oRange.MoveStart wdCharacter, ncharacterafter
                    oRange.MoveEnd wdCharacter, ncharacterbefore
                    
                    
                    oRange.Collapse wdCollapseEnd
                    
                    
                Wend
            End With
        Next CurrRowShtSearchItem
    '-----------Prepare settings for Sheet Findings (listed)-------------
       
        shtExtract.Range("A1:D1").AutoFilter
        ActiveWorkbook.Worksheets("Findings (listed)").AutoFilter.Sort.SortFields.Add2 Key:= _
        Range("B1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
        With ActiveWorkbook.Worksheets("Findings (listed)").AutoFilter.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
   
       
       Sheets("Findings (listed)").Copy After:=Sheets(Sheets.Count)
       ActiveSheet.Name = NameSheet
       
'------- VLookUp for Searchwords
             With Sheets("Cockpit")
            
            LetzteSearch = Worksheets("Cockpit").Cells(Rows.Count, 3).End(xlUp).Row + 1
            
            LetzteName = Worksheets("Cockpit").Cells(Rows.Count, 6).End(xlUp).Row + 1
            
            Anzahlsearch = LetzteSearch - 15
            
            Rangecomp = LetzteName + Anzahlsearch
        End With
        a = 15
        
        Do Until a = LetzteSearch
            If IsEmpty(Worksheets("Cockpit").Cells(a, 3)) = False Then
            Worksheets("Cockpit").Cells(a, 4) = Application.WorksheetFunction.CountIf(Worksheets("Findings (listed)").Range("A:A"), Worksheets("Cockpit").Cells(a, 3))
            End If
            a = a + 1
            
        Loop
        
    
        i = LetzteName
        y = 15
        r = Sheets.Count
        Do Until i = Rangecomp
            If Worksheets("Cockpit").Cells(i, 6).Borders(xlEdgeBottom).LineStyle <> xlNone Then
            Worksheets("Cockpit").Rows(i).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromRightOrBelow
            End If
            Worksheets("Cockpit").Cells(i, 6).Value = Worksheets("Cockpit").Cells(12, 3).Value
            Worksheets("Cockpit").Cells(i, 7).Value = Worksheets("Cockpit").Cells(y, 3).Value
            Worksheets("Cockpit").Cells(i, 8).Value = Worksheets("Cockpit").Cells(y, 4).Value
            
            y = y + 1
            i = i + 1
            
           
            
        Loop
              
        
        Application.CutCopyMode = False
        ActiveDocument.Close _
  
        
         dataFile = Dir
    Loop

 Worksheets("Cockpit").Cells(1, 1).Value = LastRow
 






 

If WordNotOpen Then
    oWord.Quit
End If
    

    
Set oWord = Nothing
Set oDoc = Nothing
    
    
Exit Sub
    
Err_Handler:
MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
    If WordNotOpen Then
    End If
    

    oWord.Quit
    Worksheets("Cockpit").Cells(12, 3).Select
    
End Sub