Function OeffneWordDatei(ByVal strPath As String, ByRef zeile As Long)
Dim strText As String
Dim objWA As Word.Application
Dim objwd As Word.Document
Dim strfile As String
Dim ilen, ipos As Integer
Dim i As Integer
Dim wdtabelle As Word.Table
Dim wdZeile As Word.Row
Dim wdZelle As Word.Cell
Dim iwdzeile As Integer
Dim iwdspalte As Integer
Dim z, s As Integer
Dim rng As Range

    strfile = Dir(strPath)
    If Len(strfile) > 0 Then
        Set objWA = CreateObject("Word.Application")
        objWA.Visible = False
        Set objwd = objWA.Documents.Open(strPath)
        objwd.AcceptAllRevisions
        
        strText = objwd.Range.Text
        ilen = Len(strPath)
        ipos = InStrRev(strPath, "\", -1, vbTextCompare)
        
        Call BestimmeSuchKapitel(objwd, wksKonfig.Cells(1, 5).Value, wksKonfig.Cells(2, 5).Value, zeile)
        objwd.Close False
        objWA.Quit
    Else
        MsgBox "Unexpected Error in OeffneWordDatei for " & strPath
    End If

End Function

Function BestimmeSuchKapitel(ByVal wdoc As Word.Document, ByVal strStart As String, ByVal strEnd As String, ByRef lZeileVar As Long)
'http://www.chf-online.de/vba/vbafindreplace.htm
Dim rngDoc As Word.Range
Dim rngTextGes As Word.Range
Dim rng As Word.Range
Dim llast As Long
Dim i As Long

    ' Range festlegen
    Set rngDoc = wdoc.Range
    ' Range festlegen
    Set rngTextGes = wdoc.Range(0, 0)
    rngTextGes.Collapse wdCollapseStart
    
  
    
    ' Such-Schleife
    With rngDoc.Find
        .Format = False
        .Text = strStart
        ' Suche nach Start-Tag
        .Execute
        ' Fundstelle mit Start-Tag anlegen
        rngTextGes.SetRange rngDoc.Start, rngDoc.End
        ' Suchtextbereich reduzieren
        rngDoc.SetRange rngDoc.End, wdoc.Range.End
        ' Suche nach End-Tag
        .Execute FindText:=strEnd, Forward:=True
        ' Abbruch wenn kein End-Tag
        If .Found = False Then Exit Function
        ' Fundstelle bis End-Tag erweitern
        rngTextGes.SetRange rngTextGes.Start, rngDoc.End
        
        llast = BestimmeLetzteZeile(wksPattern, 1)
        For i = 2 To llast
            Call DurchsucheKapitel(rngTextGes, wksPattern.Cells(i, 1).Value, lZeileVar)
        Next i
        ' Suchtextbereich zur Endposition reduzieren
        rngDoc.Collapse wdCollapseEnd
    End With
End Function

Function DurchsucheKapitel(ByVal rngKap As Word.Range, ByVal strsuch As String, ByRef lZeileVar As Long)
Dim rngText As Word.Range
Dim llast As Long
Dim strMerke As String
Dim i As Long

    llast = BestimmeLetzteZeile(wksKonfig, 8)
    Set rngText = rngKap
    'rngText.Collapse wdCollapseStart
    
    ' Such-Schleife
    With rngKap.Find
        .Format = False
        .Text = strsuch
        ' Suche nach Start-Tag
        .Execute
        
        Do While .Found = True
            ' Fundstelle mit Start-Tag anlegen
            rngText.SetRange rngKap.Start, rngKap.End
            ' Suchtextbereich reduzieren
            rngKap.SetRange rngKap.End, rngKap.End   'kann wohl raus
            ' Suche nach End-Tag
            For i = 1 To llast
                .Execute FindText:=wksKonfig.Cells(i, 8).Value, Forward:=True
                If .Found = True Then
                    rngText.SetRange rngKap.Start, rngKap.End
                    If strMerke = "" Then
                        strMerke = rngText.Text
                    Else
                        If Len(strMerke) > Len(rngText.Text) Then
                            strMerke = rngText.Text
                        End If
                    End If
                End If
            Next i
            ' Fundstelle bis End-Tag erweitern
            rngText.SetRange rngText.Start, rngKap.End
            wksVar.Cells(lZeileVar, 1).Value = strMerke
            lZeileVar = lZeileVar + 1
            
            ' Suchtextbereich zur Endposition reduzieren
            rngKap.Collapse wdCollapseEnd
            ' Start-Tag suchen
            .Execute FindText:=strsuch, Forward:=True
        Loop
        rngKap.Collapse wdCollapseEnd
    End With
End Function