Word VBA: find line and replace font

问题

I've written a VBA Word Macro that read a .txt File, copy it and paste it in a Word document setting a new font.

All is working fine! Now I would like to highlight some specific lines with bold + italic font, but i cannot figure out a working solution.

The specific lines begins with a specific word (for example Simulation Nr.xxx) or they begin with some words but then they have a very long series of blank spaces (for example Turbine).

How can i solve the problem?

P.s.: here the working code that copy/paste the .txt file into a word document.

Sub ACTUS_Table_Converter()

Dim pName As String
Dim bDoc As Document
Dim AppPath, ThisPath As String
Dim Rng As Range

ThisPath = ActiveDocument.Path
pName = ActiveDocument.Name

With Dialogs(wdDialogFileOpen)
    If .Display Then
        If .Name <> "" Then
            Set bDoc = Documents.Open(.Name)
            AppPath = bDoc.Path
        End If
    Else
        MsgBox "No file selected"
    End If
End With

Call ReplaceAllxSymbolsWithySymbols
Call ChangeFormat

Selection.Copy
Windows(pName).Activate
Selection.Paste
Selection.Collapse
bDoc.Close savechanges:=False

End Sub

Sub ChangeFormat()

Selection.WholeStory
With Selection.Font
    .Name = "Courier New"
    .Size = 6
End With

End Sub

Sub ReplaceAllxSymbolsWithySymbols()

'Call the main "ReplaceAllSymbols" macro (below),
'and tell it which character code  and font to search for, and which to replace with

Call ReplaceAllSymbols(FindChar:=ChrW(-141), FindFont:="(normal text)", _
        ReplaceChar:=ChrW(179), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:=ChrW(-142), FindFont:="(normal text)", _
        ReplaceChar:=ChrW(178), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:=ChrW(-144), FindFont:="(normal text)", _
        ReplaceChar:=ChrW(176), ReplaceFont:="(normal text)")
Call ReplaceAllSymbols(FindChar:="°", FindFont:="(normal text)", _
        ReplaceChar:="", ReplaceFont:="(normal text)")

End Sub

Sub ReplaceAllSymbols(FindChar As String, FindFont As String, _
    ReplaceChar As String, ReplaceFont As String)

Dim FoundFont As String, OriginalRange As Range, strFound As Boolean
Application.ScreenUpdating = False

Set OriginalRange = Selection.Range
'start at beginning of document
ActiveDocument.Range(0, 0).Select

strFound = False
If ReplaceChar = "" Then
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = FindChar
    .Replacement.Text = ReplaceChar
    .Replacement.Font.Name = "Courier New"
    .Replacement.Font.Size = 6
    .MatchCase = True
End With
If Selection.Find.Execute Then
    Selection.Delete Unit:=wdCharacter, Count:=2
    Selection.TypeText ("°C")
End If
Else
With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = FindChar
    .Replacement.Text = ReplaceChar
    .Replacement.Font.Name = "Courier New"
    .Replacement.Font.Size = 6
    .MatchCase = True
    .Execute Replace:=wdReplaceAll
End With
End If

OriginalRange.Select

Set OriginalRange = Nothing
Application.ScreenUpdating = True

Selection.Collapse

End Sub

回答1:

The following code should run over the document, looking for line starts with Simulation Nr. and replace the whole line font with bold and italic.

Sub ReplaceLinesStartWith()

Dim startingWord As String
'the string to search for
startingWord = "Simulation Nr."

Dim myRange As range
'Will change selection to the document start
Set myRange = ActiveDocument.range(ActiveDocument.range.Start, ActiveDocument.range.Start)
myRange.Select

While Selection.End < ActiveDocument.range.End
   If Left(Selection.Text, Len(startingWord)) = startingWord Then
        With Selection.Font
            .Bold = True
            .Italic = True
        End With
    End If

    Selection.MoveDown Unit:=wdLine
    Selection.Expand wdLine

Wend

End Sub

Note that I hardcoded the string to search for, you can set it as function argument instead.

来源：https://stackoverflow.com/questions/19680108/word-vba-find-line-and-replace-font

标签

vba

replace

fonts

ms-word

format