Selection.Find突然停止

我正在尝试编写一个程序，它遍历一个word文档集合，并在包含单词“Report Layout”的子标题内提取第一个表格（将代码重构为更多的表格）。

我写了大量的代码，直到我的Selection.Range.Start的值超过5位（97862是最大的值）。 现在，这可能意味着我使用查找是不正确的，但我不明白为什么它停止迭代通过文档。

有问题的部分：

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 

编辑 **这个问题似乎是数据相关。 标题直接到一个表和查询查询不知道如何移动过去的logging。 仍然想知道这是否可以通过移动命令来解决。