文字の置換を用いて定型文を作成する。
印刷後は別名で保存する。
表の例（あらかじめ規則にのっとり表を作成している）
文書の例（文字置換となるタグを用いている）
ワードのオブジェクトを明示しないと二回目の処理でエラーが出るので注意すること！
（この例では 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