Word VBA：查找行並替換字體

Question

我寫了一個VBA Word宏，它讀取一個.txt文件，將其複製並粘貼到Word文檔中，設置一種新字體。

所有工作正常！現在我想強調一些bold + italic字體的特定行，但我無法弄清楚一個工作解決方案。

特定行以特定詞開頭（例如Simulation Nr.xxx），或者以某些詞開頭，但它們有很長的一系列空格（例如Turbine）。

我該如何解決問題？

---

P.s .:這裏是將.txt文件複製/粘貼到word文檔中的工作代碼。

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 

Answer 1

下面的代碼應在該文件運行時，尋找符合Simulation Nr.開始，以粗體和斜體更換整個線字體。

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 

請注意，我對要搜索的字符串進行了硬編碼，您可以將其設置爲函數參數。