Selection.Find突然停止

Question

我正在尝试编写一个程序，该程序遍历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

修改 的 ** 这个问题似乎与数据有关。标题直接转到表格，查询查询不知道如何移过记录。仍然想知道是否可以使用move命令解决这个问题。