|    | 
     シンプルでわかりやすいし、今の方法がよいのでは 
というのが、わたしの考えです。 
 
ということで、ほとんど同じですが、 
置換を一括で行うように書き換えただけの案を提示。 
 
Sub 下線を引く2() 
  Dim r As Range 
  Dim myKW As String 
  Dim myKW2 As String 
  
  myKW = "<★*^13" 
  myKW2 = "<★*□" 
  
  Set r = ActiveDocument.Range 
  
  With r.Find 
    .MatchWildcards = True 
    .Text = myKW 
    .Replacement.Font.Underline = wdUnderlineThick 
    .Execute Replace:=wdReplaceAll 
    .Text = myKW2 
    .Replacement.Font.Underline = wdUnderlineNone 
    .Execute Replace:=wdReplaceAll 
  End With 
   
End Sub 
 
 
該当箇所のみ下線を引こうとすると 
コードがわかりにくくなるしメリットないような気がします。 
 
 
Sub 下線を引く3() 
  Dim r As Range 
  Dim myKW As String 
 
  myKW = "□*^13" 
 
  Set r = ActiveDocument.Range 
 
  With r.Find 
    .MatchWildcards = True 
    .Text = myKW 
    Do While .Execute 
      If r.Paragraphs(1).Range.Characters(1) = "★" Then 
        r.MoveStart wdCharacter 
        r.Underline = wdUnderlineThick 
      End If 
      r.Collapse wdCollapseEnd 
    Loop 
 
  End With 
 
End Sub 
 
 
Sub 下線を引く4() 
  Dim r As Range 
  Dim myKW As String, repWd As String 
  Dim myKW2 As String, repWd2 As String 
  
  myKW = "<(★*□)(*)^13" 
  repWd = "\1〒\2〒^p" 
   
  myKW2 = "〒(*)〒" 
  repWd2 = "\1" 
  
  Set r = ActiveDocument.Range 
  
  With r.Find 
    .MatchWildcards = True 
    .Text = myKW 
    .Replacement.Text = repWd 
    .Execute Replace:=wdReplaceAll 
    .Text = myKW2 
    .Replacement.Text = repWd2 
    .Replacement.Font.Underline = wdUnderlineThick 
    .Execute Replace:=wdReplaceAll 
  End With 
   
End Sub 
 | 
     
    
   |