Vba 选择。发现突然停止

我正在尝试编写一个程序，该程序遍历word文档集合并提取第一个表，将代码重构为包含“Report Layout”字样的副标题中的更多表

我编写的代码在很大程度上一直有效，直到我的Selection.Range.Start的值超过最大值的5位数97862。现在，这可能意味着我对find的使用是不正确的，但是我不明白它为什么停止遍历文档

问题部分：

            With wordApp.ActiveWindow.Selection.Find
                .ClearFormatting                                
                .Style = wrdDoc.Styles("Heading 3")     
                '.Text = strText       
                .Replacement.Text = ""                         
                .Forward = True                                 
                .Wrap = wdFindContinue                          
                .Format = True
                .MatchCase = False
                .MatchWholeWord = False
                .MatchWildcards = False
                .MatchSoundsLike = False
                .MatchAllWordForms = False
                .Execute
            If .Execute = False Then sh1.Cells(x, 3) = "not found"
            'If wordApp.Selection.Text = VBA.Trim$(astrHeadings(intItem)) Then


            End With

            iL4Count = iL4Count + 1                             
            ReDim Preserve Level2Heading(1 To iL4Count)         
            ReDim Preserve stringTable(1 To iL4Count)

            stringTable(iL4Count) = tableName
            Level2Heading(iL4Count) = wordApp.Selection.Range.Start      

完整代码：

Dim wrdDoc As Object, objFiles As Object, fso As Object, wordApp As Object
Dim sh1 As Worksheet
Dim x As Integer, Y As Integer, i As Integer, j As Integer, iL4Count As Integer, edTest As Integer, headerPos() As Integer, hPos As Integer
Dim rowCount As Long, columnCount As Long
Dim columnString As String
Dim validRange As String
Dim testRange As Object, testTable As Object
Dim astrHeadings As Variant
Dim Level2Heading() As Long
Dim tableHeader As String
Dim stringTable() As String
Dim regex As New VBScript_RegExp_55.RegExp
Dim regmatch As MatchCollection

FolderName = "INSERT FOLDER PATH HERE"
regex.Pattern = "[a-zA-Z]"

Set sh1 = ThisWorkbook.Sheets(1)
Set fso = CreateObject("Scripting.FileSystemObject")
Set wordApp = CreateObject("Word.application")
Set objFiles = fso.GetFolder(FolderName).Files


x = 1
For Each wd In objFiles
    If InStr(wd, ".doc") And InStr(wd, "~") = 0 Then
        'Level2Heading.erase
        Erase Level2Heading, stringTable
        intItem = 0
        iCount = 0
        iL4Count = 0
        Set testRange = Nothing
        'testRange = Null

        sh1.Cells(x, 1) = wd.Name
        Set wrdDoc = wordApp.Documents.Open(wd.Path, ReadOnly = True)

        astrHeadings = _
         wrdDoc.GetCrossReferenceItems(wdRefTypeHeading)


        For intItem = LBound(astrHeadings) To UBound(astrHeadings)
            ' Get the text and the level.
            strText = Trim$(astrHeadings(intItem))
            Set regmatch = regex.Execute(strText)
            edTest = regmatch.Item(0).FirstIndex
            strText = Right(strText, Len(strText) - edTest)
            intLevel = GetLevel(CStr(astrHeadings(intItem)))
            If intLevel = 2 Then
                tableName = strText
            End If

            'Debug.Print intLevel & " " & strText
            If intLevel = 3 Then
                wordApp.ActiveWindow.Selection.MoveLeft Unit:=1, Count:=1 'wdCharacter, Count:=1

                With wordApp.ActiveWindow.Selection.Find
                    .ClearFormatting                                
                    .Style = wrdDoc.Styles("Heading 3")     
                    '.Text = strText       
                    .Replacement.Text = ""                          
                    .Forward = True                                 
                    .Wrap = wdFindContinue                          
                    .Format = True
                    .MatchCase = False
                    .MatchWholeWord = False
                    .MatchWildcards = False
                    .MatchSoundsLike = False
                    .MatchAllWordForms = False
                    .Execute
                If .Execute = False Then sh1.Cells(x, 3) = "not found"
                'If wordApp.Selection.Text = VBA.Trim$(astrHeadings(intItem)) Then


                End With

                iL4Count = iL4Count + 1                             
                ReDim Preserve Level2Heading(1 To iL4Count)         
                ReDim Preserve stringTable(1 To iL4Count)

                stringTable(iL4Count) = tableName
                Level2Heading(iL4Count) = wordApp.Selection.Range.Start      


                If InStr(UCase(strText), "REPORT LAYOUT") > 0 Then
                    hPos = hPos + 1
                    ReDim Preserve headerPos(1 To hPos)
                    headerPos(hPos) = iL4Count
                End If

                'End If
            End If

        Next intItem
        If iL4Count > 2 Then
            For iCount = LBound(headerPos) To UBound(headerPos) - 1
                x = x + 1
                itabCount = 0

                Set testRange = wrdDoc.Range(Level2Heading(headerPos(iCount) - 1), Level2Heading(headerPos(iCount)))
                Set testTable = testRange.Tables(1)
                rowCount = testTable.Rows.Count
                columnCount = testTable.Columns.Count
                For i = 1 To rowCount
                    Y = 3
                    For j = 1 To columnCount
                    On Error Resume Next
                        validRange = testTable.Cell(Row:=i, Column:=j).Range

                        If Err.Number = 0 Then
                            columnString = Application.WorksheetFunction.Clean(validRange)
                        Else
                            columnString = ""
                            Err.Clear
                        End If
                        If Y = 3 Then
                            sh1.Cells(x, 2) = stringTable(iCount + 1)
                        End If

                        sh1.Cells(x, Y) = columnString
                        ' sh1.Cells(x, Y) = aTable.Cell(Row:=i, Column:=j).Range.Text
                        Y = Y + 1
                    Next
                    x = x + 1
                Next
            Next iCount
        Else
            sh1.Cells(x, 2) = "Do Table Manually"
            x = x + 1
        End If

    wrdDoc.Close
    End If

Next wd
wordApp.Quit
End Sub

编辑**

---

这个问题似乎与数据有关。标题直接指向一个表，而find查询不知道如何越过记录。仍然想知道是否可以使用move命令解决此问题。

作为后续操作。它可能与文档相关，尽管我还没有找到它停止迭代的原因。我对word文档进行了分区，虽然格式看起来正确，但它不会继续迭代。