VBA：格式化MS Word文本

我正在尝试格式化多个单词的文本。到目前为止，下面的代码只允许我格式化一个单词的字体。我需要添加/删除什么才能将输入的单词格式化

干杯

Sub FnFindAndFormat()

    Dim objWord
    Dim objDoc
    Dim intParaCount
    Dim objParagraph
    Set objWord = CreateObject("Word.Application")
    Set objDoc = objWord.Documents.Open("C:\USERPATH")
    objWord.Visible = True
    intParaCount = objDoc.Paragraphs.Count

    Set objParagraph = objDoc.Paragraphs(1).range
    objParagraph.Find.Text = "deal"

    Do
        objParagraph.Find.Execute
        If objParagraph.Find.Found Then
            objParagraph.Font.Name = "Times New Roman"
            objParagraph.Font.Size = 20
            objParagraph.Font.Bold = True
            objParagraph.Font.Color = RGB(200, 200, 0)
        End If


    Loop While objParagraph.Find.Found

End Sub

---

假设您的word文档如下所示

由于我不确定您是从

Word VBA

还是从其他应用程序（如say

Excel VBA

）执行此操作，因此我将这两种方法都包括在内

现在，如果您是从Word VBA执行此操作，则无需使用它进行后期绑定。使用这个简单的代码

Option Explicit

Sub Sample()
    Dim oDoc As Document
    Dim MyAr() As String, strToFind As String
    Dim i As Long

    '~~> This holds your search words
    strToFind = "deal,contract, sign, award"

    '~~> Create an array of text to be found
    MyAr = Split(strToFind, ",")

    '~~> Open the relevant word document
    Set oDoc = Documents.Open("C:\Sample.docx")

    '~~> Loop through the array to get the seacrh text
    For i = LBound(MyAr) To UBound(MyAr)
        With Selection.Find
            .ClearFormatting
            .Text = MyAr(i)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Execute

            '~~> Change the attributes
            Do Until .Found = False
                With Selection.Font
                    .Name = "Times New Roman"
                    .Size = 20
                    .Bold = True
                    .Color = RGB(200, 200, 0)
                End With
                Selection.Find.Execute
            Loop
        End With
    Next i
End Sub

但是，如果您是从say

excelvba

执行此操作，请使用

Const wdFindContinue = 1

Sub FnFindAndFormat()
    Dim objWord As Object, objDoc As Object, Rng As Object
    Dim MyAr() As String, strToFind As String
    Dim i As Long

    '~~> This holds your search words
    strToFind = "deal,contract, sign, award"

    '~~> Create an array of text to be found
    MyAr = Split(strToFind, ",")

    Set objWord = CreateObject("Word.Application")
    '~~> Open the relevant word document
    Set objDoc = objWord.Documents.Open("C:\Sample.docx")

    objWord.Visible = True

    Set Rng = objWord.Selection

    '~~> Loop through the array to get the seacrh text
    For i = LBound(MyAr) To UBound(MyAr)
        With Rng.Find
            .ClearFormatting
            .Text = MyAr(i)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Execute

            Set Rng = objWord.Selection

            '~~> Change the attributes
            Do Until .Found = False
                With Rng.Font
                    .Name = "Times New Roman"
                    .Size = 20
                    .Bold = True
                    .Color = RGB(200, 200, 0)
                End With
                Rng.Find.Execute
            Loop
        End With
    Next i
End Sub

输出

---

假设您的word文档如下所示

由于我不确定您是从

Word VBA

还是从其他应用程序（如say

Excel VBA

）执行此操作，因此我将这两种方法都包括在内

现在，如果您是从Word VBA执行此操作，则无需使用它进行后期绑定。使用这个简单的代码

Option Explicit

Sub Sample()
    Dim oDoc As Document
    Dim MyAr() As String, strToFind As String
    Dim i As Long

    '~~> This holds your search words
    strToFind = "deal,contract, sign, award"

    '~~> Create an array of text to be found
    MyAr = Split(strToFind, ",")

    '~~> Open the relevant word document
    Set oDoc = Documents.Open("C:\Sample.docx")

    '~~> Loop through the array to get the seacrh text
    For i = LBound(MyAr) To UBound(MyAr)
        With Selection.Find
            .ClearFormatting
            .Text = MyAr(i)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Execute

            '~~> Change the attributes
            Do Until .Found = False
                With Selection.Font
                    .Name = "Times New Roman"
                    .Size = 20
                    .Bold = True
                    .Color = RGB(200, 200, 0)
                End With
                Selection.Find.Execute
            Loop
        End With
    Next i
End Sub

但是，如果您是从say

excelvba

执行此操作，请使用

Const wdFindContinue = 1

Sub FnFindAndFormat()
    Dim objWord As Object, objDoc As Object, Rng As Object
    Dim MyAr() As String, strToFind As String
    Dim i As Long

    '~~> This holds your search words
    strToFind = "deal,contract, sign, award"

    '~~> Create an array of text to be found
    MyAr = Split(strToFind, ",")

    Set objWord = CreateObject("Word.Application")
    '~~> Open the relevant word document
    Set objDoc = objWord.Documents.Open("C:\Sample.docx")

    objWord.Visible = True

    Set Rng = objWord.Selection

    '~~> Loop through the array to get the seacrh text
    For i = LBound(MyAr) To UBound(MyAr)
        With Rng.Find
            .ClearFormatting
            .Text = MyAr(i)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindContinue
            .Execute

            Set Rng = objWord.Selection

            '~~> Change the attributes
            Do Until .Found = False
                With Rng.Font
                    .Name = "Times New Roman"
                    .Size = 20
                    .Bold = True
                    .Color = RGB(200, 200, 0)
                End With
                Rng.Find.Execute
            Loop
        End With
    Next i
End Sub

输出

---

对我来说很有魅力：

Public Sub Find_some_text()

'setting objects
Dim objWord
Dim objDoc
Dim objSelection

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("H:\Test.docx")

'set visibility
objWord.Visible = True

'set array of words to format
words_list = Array("Findme_1", "Findme_2", "etc")

'formatting text
For Each w In words_list
    Set Frange = objDoc.Range
    Frange.Find.Text = w
    Do
      Frange.Find.Execute
      If Frange.Find.Found Then
         Frange.Font.Name = "Times New Roman"
         Frange.Font.Size = 20
         Frange.Font.Bold = True
         Frange.Font.Color = RGB(200, 200, 0)
      End If
    Loop While Frange.Find.Found
Next

'de-set visibility
objWord.Visible = False

'saving (optional)
objDoc.Save

End Sub

---

这对我来说很有魅力：

Public Sub Find_some_text()

'setting objects
Dim objWord
Dim objDoc
Dim objSelection

Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("H:\Test.docx")

'set visibility
objWord.Visible = True

'set array of words to format
words_list = Array("Findme_1", "Findme_2", "etc")

'formatting text
For Each w In words_list
    Set Frange = objDoc.Range
    Frange.Find.Text = w
    Do
      Frange.Find.Execute
      If Frange.Find.Found Then
         Frange.Font.Name = "Times New Roman"
         Frange.Font.Size = 20
         Frange.Font.Bold = True
         Frange.Font.Color = RGB(200, 200, 0)
      End If
    Loop While Frange.Find.Found
Next

'de-set visibility
objWord.Visible = False

'saving (optional)
objDoc.Save

End Sub

此代码：

For Each w In words_list
    Set Frange = objDoc.Range
    Frange.Find.Text = w
    Do
      Frange.Find.Execute
      If Frange.Find.Found Then
         Frange.Font.Name = "Times New Roman"
         Frange.Font.Size = 20
         Frange.Font.Bold = True
         Frange.Font.Color = RGB(200, 200, 0)
      End If
    Loop While Frange.Find.Found
Next

效率低下。尝试：

With objDoc.Range.Find
  .ClearFormatting
  With .Replacement
    .ClearFormatting
    .Text = "^&"
    With .Font
      .Name = "Times New Roman"
      .Size = 20
      .Bold = True
      .Color = RGB(200, 200, 0)
    End With
  End With
  .Format = True
  .Forward = True
  .Wrap = 1 'wdFindContinue
  For Each w In words_list
    .Text = w
    .Execute Replace:=2 'wdReplaceAll
  Next
End With

此代码：

For Each w In words_list
    Set Frange = objDoc.Range
    Frange.Find.Text = w
    Do
      Frange.Find.Execute
      If Frange.Find.Found Then
         Frange.Font.Name = "Times New Roman"
         Frange.Font.Size = 20
         Frange.Font.Bold = True
         Frange.Font.Color = RGB(200, 200, 0)
      End If
    Loop While Frange.Find.Found
Next

效率低下。尝试：

With objDoc.Range.Find
  .ClearFormatting
  With .Replacement
    .ClearFormatting
    .Text = "^&"
    With .Font
      .Name = "Times New Roman"
      .Size = 20
      .Bold = True
      .Color = RGB(200, 200, 0)
    End With
  End With
  .Format = True
  .Forward = True
  .Wrap = 1 'wdFindContinue
  For Each w In words_list
    .Text = w
    .Execute Replace:=2 'wdReplaceAll
  Next
End With

---

其他单词存储在哪里？我只能看到

deal

。它们不存储在任何地方，如果代码没有出错，我无法添加更多的单词。其他单词是什么？你能说出几个吗。我想在发布codecontract、sign、awardOk之前测试一下。给我15分钟时间创建一个示例并测试它。其他单词存储在哪里？我只能看到

deal

。它们不存储在任何地方，如果代码没有出错，我无法添加更多的单词。其他单词是什么？你能说出几个吗。我想在发布codecontract、sign、awardOk之前测试一下，给我15分钟时间来创建一个示例并测试它，效果非常好！！非常感谢。在Excel VBA帮助中搜索

应用程序。GetOpenFileName

：）顺便说一句，如果你有不同的问题，那么它必须进入一个单独的线程。非常好！！非常感谢。在Excel VBA帮助中搜索

应用程序。GetOpenFileName

：）顺便说一句，如果您有不同的问题，则必须进入单独的线程。