Word VBA ワード文書の語群をExcelの辞書を使って置換

'01：2012/06/16 作成：渡辺真
'03：2012/06/28 表のセルの不要な文字を削除する方法を変更
'04：2012/06/29 ファイルを開くダイアログのパスを、この文書のパスに設定
'05：2016/11/01 フォント色による置換対象の絞込み機能を追加
'06：2016/11/04 フォント色指定を、WdColor から ColorIndex に変更

Option Explicit
Option Base 1

Public コピー元ブック名 As String
Public コピー元シート名 As String
Public コピー元参照キー列番号 As Integer
Public コピー対象列番号 As Integer
Public ワイルドカード列番号 As Integer
Public コピー元キー開始行 As Integer
Public コピー元キー開始行文字 As String

Sub Excelの辞書を使って置換()

   Dim キー列名 As String
   Dim コピー対象列名 As String
   Dim ワイルドカード列名 As String
   Dim 現在のパス As String
   Dim Excelアプリ As Object          'Excel.Application アプリ
   Dim 開始日時 As Variant
   Dim 終了日時 As Variant
   Dim 最終行 As Integer
   Dim マスタ件数 As Integer
   Dim 行 As Integer
   Dim データ() As String
   Dim 置換対象文書名 As String
   Dim 指定フォント色�� As Integer 'WdColorIndex
   Dim 文字列 As String
   
   
'   参照関係の読み込み
   ThisDocument.Activate
   現在のパス = ActiveDocument.Path
   ChDrive 現在のパス
   ChDir 現在のパス

   '★コピー元★
    
   コピー元ブック名 = ActiveDocument.Tables(1).Cell(2, 1).Range.Text
   Debug.Print コピー元ブック名
   Debug.Print InStr(コピー元ブック名, vbCr)
   Debug.Print Len(コピー元ブック名)
   'なぜか余計な2文字(0x0d(CR),0x07(BEL))が後ろに付くので、除去する。
   コピー元ブック名 = Left(コピー元ブック名, InStr(コピー元ブック名, vbCr) - 1)
   '★★↑Excelを参照設定しておかないと、予約語Leftが使えない！★★
   Debug.Print コピー元ブック名
'Stop
   コピー元シート名 = ActiveDocument.Tables(1).Cell(2, 2).Range.Text
   コピー元シート名 = Left(コピー元シート名, InStr(コピー元シート名, vbCr) - 1)

   キー列名 = ActiveDocument.Tables(1).Cell(2, 3).Range.Text
   キー列名 = Left(キー列名, InStr(キー列名, vbCr) - 1)

   If キー列名 <> "" Then
       コピー元参照キー列番号 = 列番号(キー列名)
   Else
       MsgBox "コピー元参照キー列番号が、未登録です。"
       End
   End If
   
   コピー対象列名 = ActiveDocument.Tables(1).Cell(2, 4).Range.Text
   Debug.Print コピー対象列名
   コピー対象列名 = Left(コピー対象列名, InStr(コピー対象列名, vbCr) - 1)

   ワイルドカード列名 = ActiveDocument.Tables(1).Cell(2, 5).Range.Text
   Debug.Print ワイルドカード列名
   ワイルドカード列名 = Left(ワイルドカード列名, InStr(ワイルドカード列名, vbCr) - 1)
   
   コピー元キー開始行文字 = ActiveDocument.Tables(1).Cell(2, 6).Range.Text
   Debug.Print コピー元キー開始行文字
   コピー元キー開始行 = Val(Left(コピー元キー開始行文字, InStr(コピー元キー開始行文字, vbCr) - 1))
   
   文字列 = ActiveDocument.Tables(1).Cell(2, 7).Range.Text
   Debug.Print 文字列
   文字列 = 半角(Left(文字列, InStr(文字列, vbCr) - 1))
   If Len(文字列) = 0 Then
      指定フォント色�� = 999
   Else
      指定フォント色�� = Val(文字列)
   End If
      
   コピー対象列番号 = 列番号(コピー対象列名)
   ワイルドカード列番号 = 列番号(ワイルドカード列名)
   
   MsgBox "置換対象のワード文書を指定して下さい。"
   ChangeFileOpenDirectory ThisDocument.Path
   With Dialogs(wdDialogFileOpen)
      .Name = "*.doc*"
      If .Show = -1 Then
         置換対象文書名 = .Name 'パス無しの文書ファイル名
      End If
   End With
   
   If 置換対象文書名 = ThisDocument.Name Then
      MsgBox "選択した文書は、このファイル自身です。" & vbNewLine _
      & "置換対象のファイルを選択して下さい。"
      Exit Sub
   End If

   開始日時 = Now                ' 開始時刻を変数に格納します。
   
   'Excelファイルを開きシート内のリスト全てコピー
   Set Excelアプリ = CreateObject("Excel.Application")
   Excelアプリ.Visible = True
   
   With Excelアプリ
      .Workbooks.Open (現在のパス & "\" & コピー元ブック名)
      .Workbooks(コピー元ブック名).Worksheets(コピー元シート名).Activate
   End With
   DoEvents
'Stop

   With Excelアプリ
      'マスタデータを配列に読み込む
      'マスタ側のブック名とマスタ側のテーブル名

      最終行 = .Cells(.ActiveSheet.Rows.Count, コピー元参照キー列番号).End(xlUp).Row
      '★★↑Excelを参照設定しておかないと、予約語xlUpが使えない！★★

      マスタ件数 = 最終行 - コピー元キー開始行 + 1
      
      ReDim データ(マスタ件数, 4)
      
      For 行 = コピー元キー開始行 To 最終行
         If .Cells(行, コピー対象列番号).Value <> "" Then '登録データ ★★★
             データ(行 - コピー元キー開始行 + 1, 1) _
             = .Cells(行, コピー元参照キー列番号).Value   'ID 参照キー★★★
             データ(行 - コピー元キー開始行 + 1, 2) _
             = .Cells(行, コピー対象列番号).Value         '置換後登録データ ★★★
             データ(行 - コピー元キー開始行 + 1, 3) _
             = .Cells(行, ワイルドカード列番号).Value     'ワイルドカード登録データ ★★★
         End If
      Next 行
   
   End With

   'Excel終了処理
   With Excelアプリ
      '保存しないで閉じる
      .Workbooks(コピー元ブック名).Close SaveChanges:=False
      .Quit
   End With
   
   Set Excelアプリ = Nothing
   DoEvents
    
   Documents(置換対象文書名).Activate
   
   For 行 = 1 To マスタ件数
      If Len(データ(行, 2)) > 0 Then   '置換先の文字列が空白だと、文書が消えるから
         If 指定フォント色�� > 16 Then
         Else
            Selection.Find.Font.ColorIndex = 指定フォント色��
         End If
         With Selection.Find
'               .ClearFormatting
            .Text = データ(行, 1)           '辞書のキーの文字列を
            .Forward = True
            .Wrap = wdFindContinue
            
            If 指定フォント色�� > 16 Then   'フォント色指定無し
               .Format = False
            Else
               .Format = True                '★★コレがミソ★★フォント色指定
               'True を設定すると、検索文字列と書式または書式のみの検索が行われます。
            End If
            .MatchCase = False
            .MatchByte = False

'            .MatchPhrase = False        'この行は不要。有ると Word 2003以前で動かない。

            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .MatchFuzzy = False
            
            If Len(データ(行, 3)) > 0 Then
               .MatchWildcards = True        'ワイルドカードを使う
            Else
               .MatchWildcards = False       'ワイルドカードを使わない
            End If
            
'               .Replacement.ClearFormatting
            .Replacement.Text = データ(行, 2) '辞書の置換対象の文字列に
'               .Font.Hidden = False

         End With
   
         Selection.Find.Execute Replace:=wdReplaceAll  '全て置換実行
'            Stop
      End If
   Next 行


   終了日時 = Now
   MsgBox "処理を終了しました。" & vbNewLine & "処理時間は、" _
   & Format(終了日時 - 開始日時, "hh時間nn分ss秒") & " でした。"
   
End Sub

With Selection.Find
    .Forward = True
    .Wrap = wdFindStop
    .Text = "Hello"
    .Execute
End With

Selection.Find.Execute FindText:="Hello", _
    Forward:=True, Wrap:=wdFindStop

With ActiveDocument.Content.Find
    .Text = "blue"
    .Forward = True
    .Execute
    If .Found = True Then .Parent.Bold = True
End With

Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="blue", Forward:=True
If myRange.Find.Found = True Then myRange.Bold = True

With Selection.Find
    .ClearFormatting
    .Text = "前略"
    .Replacement.ClearFormatting
    .Replacement.Text = "拝啓"
    .Execute Replace:=wdReplaceAll, Forward:=True, _
        Wrap:=wdFindContinue
End With

With ActiveDocument.Content.Find
    .ClearFormatting
    .Font.Bold = True
    With .Replacement
        .ClearFormatting
        .Font.Bold = False
    End With
    .Execute FindText:="", ReplaceWith:="", _
        Format:=True, Replace:=wdReplaceAll
End With

With Selection.Find
    .ClearFormatting
    .Text = "hi"
    .Execute Forward:=True
End With

Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="hi", ReplaceWith:="hello", _
    Replace:=wdReplaceAll

Selection.Find.Execute FindText:="blue", Forward:=True

Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="blue", Forward:=True
If myRange.Find.Found = True Then myRange.Bold = True

With Selection.Find
    .Forward = True
    .ClearFormatting
    .MatchWholeWord = True
    .MatchCase = False
    .Wrap = wdFindContinue
    .Execute FindText:="Microsoft"
End With

With Selection.Find
    .Text = "hi"
    .ClearFormatting
    .Replacement.Text = "hello"
    .Replacement.ClearFormatting
    .Execute Replace:=wdReplaceOne, Forward:=True
End With

With ActiveDocument.Content.Find
    .ClearFormatting
    .Font.Bold = True
    .Text = ""
    With .Replacement
        .ClearFormatting
        .Font.Bold = False
        .Text = ""
    End With
    .Execute Format:=True, Replace:=wdReplaceAll
End With

With ActiveDocument.Content.Find
    .ClearFormatting
    .Font.Bold = True
    With .Replacement
        .ClearFormatting
        .Font.Bold = False
    End With
    .Execute FindText:="", ReplaceWith:="", Format:=True, _
        Replace:=wdReplaceAll
End With

Set myRange = ActiveDocument.Range(Start:=0, End:=0)
With myRange.Find
    .ClearFormatting
    .Text = "Start"
    With .Replacement
        .ClearFormatting
        .Text = "End"
    End With
    .Execute Replace:=wdReplaceAll, _
        Format:=True, MatchCase:=True, _
        MatchWholeWord:=True
End With

Set newDoc = Documents.Add
Set myRange = newDoc.Content
myRange.InsertAfter "これは太字にするテストです。"
myRange.Words(6).Bold = True

If Selection.Type = wdSelectionNormal Then
    If Selection.Font.Bold = wdUndefined Then _
        Selection.Font.Bold = True
Else
    MsgBox "文字列を選択してください。"
End If

If Selection.Type = wdSelectionNormal Then
    Selection.Range.Bold = wdToggle
End If

ActiveDocument.Paragraphs(1).Range.Bold = True

With Selection.Find
    .ClearFormatting
    .MatchWholeWord = True
    .MatchByte = False
    .Execute FindText:="マイクロソフト"
End With

With Selection.Find
    .ClearFormatting
    .Text = "s?t"
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchFuzzy = False
    .MatchWildcards = True
    .Execute Format:=False, Forward:=True
End With

Sub ShowOpenDialog()
    Dialogs(wdDialogFileOpen).Show
End Sub

Sub ShowPrintDialog()
    Dialogs(wdDialogFilePrint).Show
End Sub

Sub ShowBorderDialog()
    With Dialogs(wdDialogFormatBordersAndShading)
        .DefaultTab = wdDialogFormatBordersAndShadingTabPageBorder
        .Show
    End With
End Sub

Sub DisplayUserInfoDialog()
    With Dialogs(wdDialogToolsOptionsUserInfo)
        .Display
        MsgBox .Name
    End With
End Sub

Sub DisplayUserInfo()
    MsgBox Application.UserName
End Sub

Sub ShowAndSetUserInfoDialogBox()
    With Dialogs(wdDialogToolsOptionsUserInfo)
        .Display
        If .Name <> "" Then .Execute
    End With
End Sub

Sub SetUserName()
    Application.UserName = "鈴木 純"
    Dialogs(wdDialogToolsOptionsUserInfo).Display
End Sub

Sub ShowRightIndent()
    Dim dlgParagraph As Dialog
    Set dlgParagraph = Dialogs(wdDialogFormatParagraph)
    MsgBox "右インデント = " & dlgParagraph.RightIndent
End Sub

Sub ShowRightIndexForSelectedParagraph()
    MsgBox Selection.ParagraphFormat.RightIndent
End Sub

Sub SetKeepWithNext()
    With Dialogs(wdDialogFormatParagraph)
        .KeepWithNext = 1
        .Execute
    End With
End Sub

Sub SetKeepWithNextForSelectedParagraph()
    Selection.ParagraphFormat.KeepWithNext = True
End Sub

Sub DialogBoxButtons()
    If Dialogs(wdDialogInsertBreak).Show = -1 Then
        StatusBar = "改ページが挿入されました。"
    End If
End Sub

ChangeFileOpenDirectory "C:\Documents"
Documents.Open FileName:="Test.doc"

ChangeFileOpenDirectory "C:\"
Dialogs(wdDialogFileOpen).Show

Sub SetFirstDoc()
    Dim docFirst As Document
    Set docFirst = Documents.Item(1)
End Sub

Sub SetFirstDoc()
    Dim docFirst As Document
    Set docFirst = Documents(1)
End Sub

Sub ActivateDocument()
    Documents("Sales.doc").Activate
    MsgBox ActiveDocument.Name
End Sub

Sub SelectBookmark()
    ActiveDocument.Bookmarks(1).Select
    MsgBox Selection.Text
End Sub

Sub AddBorderToFirstParagraphInSelection()
    With Selection.Paragraphs(1).Borders(wdBorderBottom)
        .LineStyle = wdLineStyleSingle
        .LineWidth = wdLineWidth300pt
        .Color = wdColorBlue
    End With
End Sub

Dim dlgFind As Dialog

Set dlgFind = Dialogs(wdDialogEditFind)

With dlgFind
    .Find = "Hello"
    .Show
End With

With Dialogs(wdDialogFileOpen)
    .Name = "*.*"
    .Show
End With

Dialogs(wdDialogFilePrint).Execute

With  Dialogs(wdDialogEditFind)
    .Find = "Blue"
    .Show
End With

With Dialogs(wdDialogFileOpen)
    .Name = "*.*"
    .Show
End With

Dialogs(wdDialogViewZoom).Show TimeOut:=9000

Dim dlgAbout As Dialog

Set dlgAbout = Dialogs(wdDialogHelpAbout)
dlgAbout.Display

Dialogs(wdDialogViewZoom).Display TimeOut:=9000

With Selection.Find
    .ClearFormatting
    .MatchWholeWord = True
    .MatchCase = False
    .Execute FindText:="library"
End With

Set myRange = ActiveDocument.Content
myRange.Find.Execute FindText:="前略", _
    ReplaceWith:="拝啓", Replace:=wdReplaceAll

With Selection.Characters(1)
    .Bold = True
    .Font.Size = 24
End With

With ActiveDocument
    .Paragraphs(1).Range.InsertParagraphAfter
    .Paragraphs(2).Range.InsertBefore "新しい文字列"
End With

Set doc = ActiveDocument
Set rngRange = _
    doc.Range(doc.Paragraphs(1).Start, _
    doc.Paragraphs(1).End - 1)
rngRange.InsertAfter _
    "段落 (1) の最後の文"

ActiveDocument.Content.InsertAfter "文書の末尾"

With Selection
    .InsertAfter "文字列の追加"
    .Collapse Direction:=wdCollapseEnd
End With

response = InputBox("文字を入力してください。")
With ActiveDocument.Paragraphs(1).Range
    .InsertAfter "1." & Chr(9) & response
    .InsertParagraphAfter
End With

With Selection
    .InsertBefore Chr(34) & "Hamlet" & Chr(34) & Chr(32)
    .Collapse Direction:=wdCollapseEnd
End With

With ActiveDocument.Content
    .InsertParagraphBefore
    .InsertBefore "はじめに"
End With

Documents.Add
For Each aFont In FontNames
    With Selection
        .InsertBefore aFont
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
    End With
Next aFont

dlgAnswer = Dialogs(wdDialogFileOpen).Show

With  Dialogs(wdDialogEditFind)
    .Find = "Blue"
    .Show
End With

With Dialogs(wdDialogFileOpen)
    .Name = "*.*"
    .Show
End With

Dialogs(wdDialogViewZoom).Show TimeOut:=9000

Dim dlgFind As Dialog

Set dlgFind = Dialogs(wdDialogEditFind)

With dlgFind
    .Find = "Hello"
    .Show
End With

With Dialogs(wdDialogFileOpen)
    .Name = "*.*"
    .Show
End With

Dialogs(wdDialogFilePrint).Execute

With Dialogs(wdDialogFilePageSetup)
    .DefaultTab = wdDialogFilePageSetupTabPaperSource
    .Show
End With