エクセルの表で入力する文字を管理し、
文字の置換を用いて定型文を作成する。
印刷後は別名で保存する。

表の例（あらかじめ規則にのっとり表を作成している）

文書の例（文字置換となるタグを用いている）

ワードのオブジェクトを明示しないと二回目の処理でエラーが出るので注意すること！
（この例では　wdObj で明示している）

＜サンプル＞
    Dim wdObj As Object 'オブジェクト（ワードブック）

    Dim i As Long, x As Long
    Dim myBef As String '変換前
    Dim myAft As String '変換後

    Dim myTotal As Long '期間中の合計金額

    Const kaku As String = ".doc" '拡張子
    Const startCol As Long = 5 '5列目から処理を開始する
    Const befYear As Long = 5 '過去五年までさかのぼる


Sub 文字を置換して印刷し保存する()
    '事前に・・・

    '①[参照設定]で「Microsoft Word 11.0 Object Library」をチェックします。
    'verは変更になっていることもあるので、
    'それらしい物を探してみましょう。

    '②wordで作成した文書を保管しておきます。
    'ここで例として使用したタグは
    '《本年》　《一年前》　《一年前の金額》　《合計金額》
    'などです


    '～～～変数の宣言
    Dim myAdress As String 'ｱﾄﾞﾚｽとファイル名を格納
    Dim mySury As Long '数量が書かれた列数

    '↓↓↓ここから↓↓↓ScreenUpdatingをfalseにしていると処理できないので注意する
    Application.ScreenUpdating = True

    '～～～入力開始
    i = 3 'データは三行目から記されている
    Do While Cells(i, "B").Value <> ""
        Call main処理

        '次の行へ
        i = i + 1
    Loop

'    Application.ScreenUpdating = True
'    Application.ScreenUpdating = False
    '↑↑↑ここまで↑↑↑ScreenUpdatingをfalseにしていると処理できないので注意する
End Sub

Private Sub main処理()
    '！！！ワードの操作を開始！！！
   '指定したディレクトリがあるか確認する
    myAdress = Cells(i, "C").Value & "\" & Cells(i, "D").Value
    If Dir(myAdress) = "" Then
        '指定したディレクトリがない　→　ファイル名を記したセルを赤色にする
        Cells(i, "D").Interir.Color = vbRed　
        GoTo ex
    End If

    If Cells(i, "A").Value <> "" Then
        '変数の宣言
        Set wdObj = CreateObject("word.Application")
        Dim wordFile As String

        '合計金額の変数を0にします
        myTotal = 0

        'オープンするワードのファイル名をパス名付きで入れます
        wordFile = myAdress '& kaku

        '1：ワードを開きます
        With wdObj
            .Visible = True
            .Documents.Open wordFile
        End With

        '2：書き込み
        '2-0：ループなしで置換する
        myBef = "《本年》"   '年を指している部分を探す
        myAft = Format(Date, "ggge年m月d日") '和暦

        Call 置換開始

        '2-1：befYear年分さかのぼって置換（合計金額なし）
        For x = startCol To startCol + befYear - 1
            '～～～年
            myBef = "《" & Cells(2, x).Value & "》"   '年を指している部分を探す
            myAft = Format(DateAdd("yyyy", -x + befYear - 1, Date), "ggge年") '和暦

            Call 置換開始


            '～～～数量
            '数量は特に合計を求めない
            mySury = x + befYear '数量が記された列数
            myBef = "《" & Cells(2, mySury).Value & "の数量》"   '数量を指している部分を探す
            myAft = Format(Cells(i, mySury).Value, "#,##0")

            Call 置換開始
        Next x


        '2-2：befYear年分さかのぼって置換（合計金額あり）
        For x = startCol To startCol + befYear
           '～～～金額
            myBef = "《" & Cells(2, x).Value & "の金額》" '金額を指している部分を探す
            myAft = Format(Cells(i, x).Value, "\\#,##0")

            Call 置換開始_合計込
        Next x


        '3：合計金額を入力する
        If myTotal >= 1 Then
            '合計金額入力
            myBef = "《合計金額》"    '合計金額を指している部分を探す
            myAft = Format(myTotal, "\\#,##0") '集計結果
            Call 置換開始_合計込
        Else
            '金額がないので空白を入力する
            myBef = "《合計金額》"    '合計金額を指している部分を探す
            myAft = "" '←空白
            Call 置換開始
        End If


        '4:プリントアウト
         ActiveDocument.PrintOut

        '5:別名で保存
        wdObj.ActiveDocument.SaveAs Filename:=Cells(i, "C").Value & "\" & Cells(i, "B").Value & Year(Date) & kaku

        '6:ワードを閉じます
        wdObj.Quit
    End If

    'wdObjの制御を破棄
    Set wdObj = Nothing

’処理がファイルがない場合はココに飛ぶ
ex:

End Sub
Private Sub 置換開始()
    With wdObj.ActiveDocument.Content.Find
            .Text = myBef
            .Format = True '検索・置換をする

            If .Execute Then
                'myBefが見つかった場合の処理
                With .Replacement
                    .Text = myAft
                End With
                .Execute Replace:=wdReplaceAll
            End If
    End With
End Sub

Private Sub 置換開始_合計込()
    With wdObj.ActiveDocument.Content.Find
        .Text = myBef
        .Format = True '検索・置換をする

        If .Execute Then
            'myBefが見つかった場合の処理
            With .Replacement
                .Text = myAft
            End With
            .Execute Replace:=wdReplaceAll
            '合計金額算出
            myTotal = myTotal + Cells(i, x).Value
        End If
    End With
End Sub

(表との連携)エクセルの表でワードの文書を管理する方法