1

私は、ある Word 文書の頭字語の表を解析し、別の Word 文書でこれらの頭字語が出現するたびに強調表示する Word マクロ (以下) をまとめているところです。これは機能しているようです。

ただし、括弧内にある頭字語とそうでない頭字語をマクロで区別したいと考えています。例えば、

兵士は無断欠勤 (AWOL) と見なされます。AWOLの職員は逮捕される可能性があります。

次のコードを使用して Do-While ループで最初に展開すると、見つかった頭字語を定義する範囲 "oRange" を評価できるようです。

oRange.SetRange 開始:=oRange.Start - 1、終了:=oRange.End + 1

ただし、解決策をコーディングしようとしてもうまくいかないようです (マクロが無限ループに陥るか、エラー メッセージが表示されます)。私は VBA プログラミングにかなり慣れていないので、ループがどのように動作しているかについて明らかに何かが欠けています。

私の質問は次のとおりです。その後の操作のために範囲「oRange」を複製する方法はありますか、それとも使用すべき他の方法がありますか?

ご協力いただきありがとうございます。

Sub HighlightAcronyms()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim TableNo As Integer 'table number in Word
Dim oRow As Row
Dim oCell As Cell
Dim sCellText As String

Dim oDoc_Source As Document
Dim strListSep As String
Dim oRange As Range
Dim n As Long
Dim sCellExpanded As String

    'Application.ScreenUpdating = False
    strListSep = Application.International(wdListSeparator)

'*** Select acronym file and check that it contains one table

wdFileName = WordApplicationGetOpenFileName("*.docx", True, True)
If wdFileName = False Then Exit Sub '(user cancelled import file browser)
Set wdDoc = GetObject(wdFileName) 'open Word file
With wdDoc
    TableNo = wdDoc.Tables.Count
    If TableNo = 0 Then
        MsgBox "The file """ & wdFileName & """ contains no tables.", _
        vbExclamation, "Import Word Table"

        ElseIf TableNo > 1 Then
             MsgBox "The file """ & wdFileName & """ contains multiple tables.", _
            vbExclamation, "Import Word Table"
    End If
End With

'*** steps through acronym column

wdDoc.Tables(1).Cell(1, 1).Select
Selection.SelectColumn
For Each oCell In Selection.Cells
    ' Remove table cell markers from the text.
    sCellText = Left$(oCell.Range, Len(oCell.Range) - 2)
    sCellExpanded = "(" & sCellText & ")"
    n = 1
    'need to find foolproof method to select document for highlighting
    Documents(2).Activate
    Set oDoc_Source = ActiveDocument

    With oDoc_Source
        Set oRange = .Range
        With oRange.Find
            .Text = sCellText
            .Forward = True
            .Wrap = wdFindStop
            .Format = False
            .MatchCase = True
            .MatchWildcards = False
            Do While .Execute
                If n = 1 Then
                    oRange.HighlightColorIndex = wdGreen
                Else
                    oRange.HighlightColorIndex = wdYellow
                End If
       'trying to add code here to expand oRange and compare it to sCellExpanded
                n = n + 1
            Loop
        End With
    End With
Next oCell

Set wdDoc = Nothing
End Sub
4

1 に答える 1

0

これを試して

  1. をマージする代わりに、2 つの範囲を定義しoRangeます。

このサンプル コードを参照してください (試行およびテスト済み)

Sub Sample()
    Dim strSearch As String, sCellExpanded As String
    Dim oRange As Range, newRange As Range

    strSearch = "AWOL"
    sCellExpanded = "(" & strSearch & ")"

    Set oRange = ActiveDocument.Range

    With oRange.Find
        .ClearFormatting
        .Text = strSearch
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False

         Do While .Execute
            If n = 1 Then
                oRange.HighlightColorIndex = wdGreen
            Else
                oRange.HighlightColorIndex = wdYellow
            End If

            '~~> To check if the found word is not the 1st word.
            If oRange.Start <> 0 Then
                Set newRange = ActiveDocument.Range(Start:=oRange.Start - 1, End:=oRange.End + 1)
                If newRange.Text = sCellExpanded Then
                    '
                    '~~> Your code here
                    '
                    newRange.Underline = wdUnderlineDouble
                End If
            End If
            n = n + 1
         Loop
    End With
End Sub

スナップショット

現在、画像をアップロードできません。ただいまimgurのサーバーがダウンしております。

このリンクが表示される場合があります

http://wikisend.com/download/141816/untitled.png

于 2012-08-10T06:11:48.740 に答える