Range.Find - wdInFieldResultで.Foundとのトラブル

Question

頭字語検索

findRng.Findが正常TOCの開始時に次の.Executeが始まる（例えば目次など）フィールドの実行結果内の検索テキストを発見

以前のfindRng.Findからの文書のさらに下に設定されていた開始位置ではなく、 findRng.selectを選択すると、これを視覚的に表示できます。 findRngのStartプロパティとEndプロパティには、TOCの開始は含まれていないはずですが、これはAppleの本社のアドレスになるため、.Findメソッドも使用されているようです。すなわち、1つの無限ループ。 ;）

期待どおりのfindRng.Startと.Endの値は、サブルーチンの下部に近い.Executeステートメントまで見ることができます。

誰もがレンジリセットの問題を解決できない限り、私はただちにwdInFieldResultをトリガーするフィールドの.Endの位置を決定して、真実を伝え、人生を変えていく方法を見つけてうれしく思います。

Sub findAcronyms() 
     Dim findRng As Range, tempRng As Range 
     Dim oFld As Field 
     Dim findStr As String, acroStr As String 
     Dim acroTbl As Table 
     '################# test code 
     Dim testMode As Boolean 
     Dim testIdx As Long, testSize As Long, i As Long 
     testMode = True 
     testIdx = 0 
     testSize = 25 
     If testMode Then 
      ThisDocument.ShowRevisions = True 
      ThisDocument.TrackRevisions = True 
     End If 
     Quiet (Not testMode) 
     '################# 

     'set acroTbl to ThisDocument's Acronym table 
     Set findRng = ThisDocument.Content 
     findStr = "ACRONYMS" 
     With findRng.Find 
      .ClearFormatting 
      .Style = WdBuiltinStyle.wdStyleHeading1 
      .Text = findStr 
      .Forward = False 
      .Wrap = wdFindStop 
      .Format = False 
      .Execute 
      If Not .Found Then 
       MsgBox findStr & ": not found!", vbExclamation 
       Stop 
       Debug.Print "Debug the issue..." 
      Else 
       findRng.MoveStart wdTable 
       findRng.Expand wdTable 
       Set acroTbl = findRng.Tables(1) 
      End If 
     End With 

     'find occurrences of "(" and if closing parens "(" is within 7 characters then add to end of Acronym table 
     Set findRng = ThisDocument.Content 
     findStr = "(" 
     With findRng.Find 
      .ClearFormatting 
      .Text = findStr 
      .Forward = True 
      .Wrap = wdFindStop 
      .Format = False 
      .Execute 
      Do While .Found 'until Find finds other than itself or EOD 
     '################# test code 
      If testMode Then 
       findRng.Select 
       Debug.Print findRng.Start 
       testIdx = testIdx + 1 
       If testIdx > testSize Then 
        Stop 'and Debug if necessary 
        Exit Sub 
       End If 
      End If 
     '################ 
       i = findRng.MoveEndUntil(")", 7) 
       If i > 2 And Not findRng.Text Like Left(findStr & "#######", _ 
    Len(findRng.Text)) Then 
        'check for pre-existence of acronym before adding to table 
        Set tempRng = ThisDocument.Range(acroTbl.Columns(1).Cells(2).Range.Start, _ 
    acroTbl.Columns(1).Cells(acroTbl.Columns(1).Cells.Count).Range.End) 
        tempRng.Find.ClearFormatting 
        With tempRng.Find 
        .Text = Mid(findRng.Text, 2, i) 
        .Forward = True 
        .Wrap = wdFindStop 
        .Format = False 
        .MatchCase = False 
        .MatchWholeWord = True 
        .MatchWildcards = False 
        .MatchSoundsLike = False 
        .MatchAllWordForms = False 
        .Execute 
        If Not .Found Then 'proceed with adding new acronym to table 
         With acroTbl.Rows 
          .Add 
          With .Last 
           .Cells(1).Range.Text = Mid(findRng.Text, 2, i) 
           i = findRng.Start 
           findRng.Collapse wdCollapseStart 
           findRng.MoveStart wdCharacter, -1 
           findRng.MoveStart wdWord, _ 
    -.Cells(1).Range.Characters.Count 
           .Cells(2).Range.Text = Trim(findRng.Text) 
           findRng.Start = i + 1 
     Debug.Print .Cells(1).Range.Text, .Cells(2).Range.Text 
          End With 
         End With 
        End If 
        End With 
       Else: findRng.MoveStart wdWord 'skip over 2 letter acronyms 
       End If 
       If findRng.Information(wdInFieldResult) Then 
        findRng.MoveStart wdParagraph 'in lieu of a better solution I need to determine how to get out of the field result 
       ElseIf findRng.Information(wdWithInTable) Then 
        If findRng.InRange(findRng.Tables(1).Range.Cells(findRng.Tables(1).Range.Cells.Count).Range) Then 'test if in last cell 
        findRng.Expand wdTable 
        findRng.Collapse wdCollapseEnd 
        Else 
        findRng.MoveStart wdCell 
        End If 
       Else 
        findRng.MoveStart wdWord 
       End If 
     '################# test code 
       If testMode Then findRng.Select 
     '################ 
       findRng.Collapse wdCollapseEnd 
       findRng.End = ThisDocument.Content.End 
       .Execute 
      Loop 
     End With 
     Stop 
     End Sub 

Answer 1

Field.Resultの壊れた動作を回避すると、実際にはルーチンが単純化されました。代わりにRange.MoveStartUntilを使用すると、より簡単な処理が可能になりました。

findAcronymsルーチンは、連続した括弧「（」が文書の終わりに達するまで）毎にThisDocument.Contentを検索します。開いている括弧を見つけると、いくつかのフィルタリングテストが実行され、数字ストリングや余分な頭字語の長さ（7文字に制限されています）成功した​​場合、頭字語は既存の頭字語の表と比較されてからTrack Changesが有効になります複数の頭字語（末尾の文字= "s"

最後に、新しく追加された頭文字が画面にスクロールされ、ユーザーがテーブルをそのまま受け入れて並べ替えるかどうかを尋ねるメッセージが表示されます。 o checkAcronymUseルーチンを使用して逆引きを実行します。このSubrは、テーブル内の各頭字語が実際に文書に現れるかどうかを検証します。事前入力済みの略語表を使用して、既存のテンプレートから文書を調整する場合に役立ちます。

Option Explicit 

Sub findAcronyms() 
    Dim findRng As Range, tempRng As Range 
    Dim findStr As String, acroStr As String 
    Dim acroTbl As Table 
    Dim sBool As Boolean 
'################# test code 
Dim testMode As Boolean 
Dim testIdx As Long, testSize As Long, i As Long, j As Long 
testMode = False 
testIdx = 0 
testSize = 100 
Quiet (Not testMode) 
'################# 

'update all field codes and scroll to first occurrence of error 
    i = ThisDocument.Content.Fields.Update 
    If i > 0 Then 
     ThisDocument.ActiveWindow.ScrollIntoView ThisDocument.Range(i) 
     Stop 'and Debug as req'd 
     Exit Sub 
    End If 

    'set acroTbl to ThisDocument's Acronym table 
    Set findRng = ThisDocument.Content 
    findStr = "ACRONYMS" 
    With findRng.Find 
     .ClearFormatting 
     .Style = WdBuiltinStyle.wdStyleHeading1 
     .Text = findStr 
     .MatchWholeWord = False 
     .Forward = False 
     .Wrap = wdFindStop 
     .Format = False 
     .Execute 
     If Not .Found Then 
     MsgBox findStr & ": not found!", vbExclamation 
     Debug.Print "Debug the issue..." 
     Stop 
     Else 
     findRng.MoveStart wdTable 
     findRng.Expand wdTable 
     Set acroTbl = findRng.Tables(1) 
     End If 
    End With 

' Main Loop: find occurrences of "(" and if closing parens ")" is within 7 characters then add to end of Acronym table 
    Set findRng = ThisDocument.Content 
    findStr = "(" 

    With findRng 
     While .MoveStartUntil(findStr) > 0 
     sBool = False 
'################# test code 
If testMode Then 
    .Select 
    Debug.Print .Start 
    testIdx = testIdx + 1 
    If testIdx > testSize Then GoTo Finish 
End If 
'################ 
     Set tempRng = .Duplicate 
     tempRng.End = .Start 
     i = tempRng.MoveEndUntil(")", 7) 'returns # of chars moved plus 1 
     If i > 3 Then 'filter out occurrences of single char parens; (?) 
      acroStr = Mid(tempRng.Text, 2, i) 
      If Right(acroStr, 1) = "s" Then 
       sBool = True 
       acroStr = Left(acroStr, Len(acroStr) - 1) 'exclude redundant plural form of acronym 
      End If 
      If Not acronymExists(acroTbl, acroStr) Then 
       addAcronym acroTbl, findRng.Duplicate, acroStr 
       If sBool Then 'remove plural "s" from acronym definition 
        With acroTbl.Rows.Last.Cells(2).Range 
        j = InStrRev(.Text, "s") 
        If j = Len(.Text) - 2 Then 'all cells contain two hidden characters after the end of text 
         ThisDocument.TrackRevisions = True 
         .Text = Mid(.Text, 1, j - 1) 
         ThisDocument.TrackRevisions = False 
        End If 
        End With 
       End If 
      End If 
      .MoveStart wdCharacter, i 
     Else: .MoveStart wdCharacter, 2 
     End If 
     Wend 
    End With 
Finish: 
    ThisDocument.ActiveWindow.ScrollIntoView acroTbl.Range, False 
    If MsgBox("Accept and Sort Acronym table edits?", 65572, "Accept?") = 6 Then 
     With acroTbl 
     .Sort ExcludeHeader:=True, FieldNumber:="Column 1", SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, CaseSensitive:=True, LanguageID:=wdEnglishUS 
     .Range.Revisions.AcceptAll 
     End With 
    End If 
    If MsgBox("Verify Acronym table?", 65572, "Verify?") = 6 Then checkAcronymUse 
    Quiet (False) 
End Sub 

Sub checkAcronymUse() 
    Dim Rng As Range, findRng As Range 
    Dim srcDoc As Document 
    Dim myTblStyl As Style 
    Dim srcTbl As Table, tgtTbl As Table 
    Dim myRow As row 
    Dim r As Long 
    Dim findStr As String, srcAddr As String, srcDocName As String 
    Dim findBool As Boolean 
'################# test code 
Dim testMode As Boolean 
Dim testSize As Long 
testMode = False 
testSize = 20 
Quiet (Not testMode) 
'################# 

'set srcTbl to ThisDocument's Acronym table 
    Set Rng = ThisDocument.Content 
    findStr = "ACRONYMS" 
    With Rng.Find 
     .ClearFormatting 
     .Style = WdBuiltinStyle.wdStyleHeading1 
     .Text = findStr 
     .Forward = False 
     .Wrap = wdFindStop 
     .Format = False 
     .Execute 
     If Not .Found Then 
     MsgBox findStr & ": not found!", vbExclamation 
     Debug.Print "Debug the issue..." 
     Stop 
     Else 
     Rng.MoveStart wdTable 
     Rng.Expand wdTable 
     Set tgtTbl = Rng.Tables(1) 
     End If 
    End With 

    ThisDocument.ShowRevisions = True 
    ThisDocument.TrackRevisions = True 

    For Each myRow In tgtTbl.Rows 
     With myRow 
     If Not .HeadingFormat Then 'ignore column headings 
      findStr = Left(.Cells(1).Range.Text, .Cells(1).Range.Characters.Count - 1) 
      If Len(findStr) < 3 Then findStr = Left(.Cells(2).Range.Text, .Cells(2).Range.Characters.Count - 1) 
       Set findRng = ThisDocument.Content 
       findBool = False 'true if Find is outside of tgtTbl 
       With findRng.Find 
        .ClearFormatting 
        .MatchCase = True 
        .MatchWholeWord = False 
        .Text = findStr 
        .Forward = True 
        .Wrap = wdFindStop 
        .Format = False 
        .Execute 
        Do While .Found 'until Find finds other than itself or EOD 
        If findRng.InRange(tgtTbl.Range) Then 
         findRng.Expand wdTable 
        Else 
         findBool = True 
         Exit Do 
        End If 
        findRng.Collapse wdCollapseEnd 
        findRng.End = ThisDocument.Content.End 
        .Execute 
        Loop 
       End With 
'################# test code 
If testMode And .Index > testSize Then Exit For 
'################ 
      If Not findBool Then .Delete 'acronym not used; delete from table 
     End If 
     End With 
    Next myRow 
'################# 
If testMode Then Stop 
'################ 
    tgtTbl.Select 
    ThisDocument.TrackRevisions = False 
    Quiet (False) 
End Sub 

Function acronymExists(acroTbl As Table, str As String) As Boolean 'check for pre-existence of acronym to avoid duplication in acronym table 
    Dim tempRng As Range 

    If str Like Left("#######", Len(str)) Then 'filter out numerical strings 
     acronymExists = True 
    Else 
     Set tempRng = ThisDocument.Range(acroTbl.Columns(1).Cells(2).Range.Start, acroTbl.Columns(1).Cells(acroTbl.Columns(1).Cells.Count).Range.End) 
     tempRng.Find.ClearFormatting 
     With tempRng.Find 
     .Text = str 
     .Forward = True 
     .Wrap = wdFindStop 
     .Format = False 
     .MatchCase = False 
     .MatchWholeWord = True 
     .MatchWildcards = False 
     .MatchSoundsLike = False 
     .MatchAllWordForms = False 
     .Execute 
     acronymExists = .Found 
     End With 
    End If 
End Function 

Sub addAcronym(acroTbl As Table, Rng As Range, str As String) 
    Dim ctr As Integer 

    ctr = Len(str) 
    ThisDocument.ShowRevisions = True 
    ThisDocument.TrackRevisions = True 

    With acroTbl.Rows 
     .Add 
     With .Last 
     .Cells(1).Range.Text = str 
     Rng.Collapse wdCollapseStart 
     'check words at, before, and just after ctr locations for simple correlation match to str 
     If Left(Rng.Previous(wdWord, ctr), 1) = Left(str, 1) Then 
      Rng.MoveStart wdWord, -ctr 
     ElseIf Left(Rng.Previous(wdWord, ctr + 1), 1) = Left(str, 1) Then 
      Rng.MoveStart wdWord, -ctr - 1 
     ElseIf Left(Rng.Previous(wdWord, ctr - 1), 1) = Left(str, 1) Then 
      Rng.MoveStart wdWord, -ctr + 1 
     Else: Rng.MoveStart wdWord, -ctr 'default, grab preceding words matching length of str 
     End If 
     .Cells(2).Range.Text = Trim(Rng.Text) 
     End With 
    End With 
    ThisDocument.TrackRevisions = False 
End Sub 

Sub Quiet(Optional bool As Boolean = True) 
    bool = Not bool 
    With Application 
     .ScreenUpdating = bool 
     .DisplayStatusBar = bool 
    End With 
End Sub