このマクロは、CSVファイルのデータを基にしてワードファイル中の任意の場所にデータを挿入するマクロ(差し込み印刷マクロ)(Word VBA)です。
年賀状、案内状、送付状などの文書の作成の際に役立ちます。
\Word VBAを学べる貴重な一冊 /
概要
以下に、このマクロの概要をイラストで示します。
詳細説明
マクロの準備
1.ワードマクロの実行方法 ~dotmファイルの作成~に記載したステップ①の0~6までを実施した後、ステップ①の7で、この記事の最後から2つ目にある標準モジュール用コードを標準モジュールのModule1にコピペします。
コピペすると、以下の状態になります。
2.「挿入」をクリックして、「ユーザーフォーム」を選択します
以下の状態になります。
(ツールボックスが表示されていない場合は、「表示」→「ツールボックス」で表示させてください。フォームが表示されなくなった場合は、User Form1をダブルクリックしてください)
3.ツールボックス上の「A」のマークを選択します
4.フォームの上に、ラベルを設置します
(カーソルをフォームの上に持っていって、左クリックしながら、以下のイラストように広げます)
5.ツールボックス上の「ab」のマークを選択します
6.フォームの上に、コマンドボタンを設置します
(カーソルをフォームの上に持っていって、左クリックしながら、以下のイラストように広げます)
7.フォーム上に先ほど設置したコマンドボタン(赤丸部分)の上で、ダブルクリックします
以下の状態になります
8.右側に表示されているコードをすべて選択します
選択したコードを消します(以下のイラストの状態にします)
9.この記事の一番最後にあるフォーム用コードを上のイラストの右側の空白部分にコピペします
コピペすると、以下のイラストの状態になります
10.ワードマクロの実行方法 ~dotmファイルの作成~に記載したステップ①の8から22までを行ってください。
(ステップ①の11では、「Project.Module1.MailMergeStart」を選択してから、追加ボタンを押してください(以下のイラストのようにしてください))
(ステップ①の13では、お好きなアイコンを選んでください)
(ステップ①の20での保存名は何でもいいです)
このマクロをどのワード文書からも呼び出せるようにしたい場合は、ワードマクロの実行方法 ~dotmファイルの作成~に記載したステップ②も行ってください。
次に、置換用CSVファイルを準備しましょう。
置換用CSVファイルの作成
1.エクセルを開いて、以下のイラストのような感じで、各自が好きなデータを登録します
- CSVファイルの一行目に、置換位置の目印となるデータを登録します。
- 以下のイラストの例では、置換位置目印データとして★1~★4が登録されていますが、文書中の文字と重複しなければ何でもOKです)。
- 置換位置目印データは、半角全角小文字大文字に注意してください。
- 置換位置目印データの置換の際には、全角半角小文字大文字が区別されます。
- 置換用データの登録は、二行目から行ってください。
- 登録は、A1セルから行ってください。
- この例では、全部で4行4列ですが、データの行数と列数に制限はありません。
2.CSVファイルを作成します
「ファイル」をクリックします
「名前を付けて保存」をクリックした後、→ 「参照」をクリックします
好きな名前を付け(この例では、「置換用CSV」)、ファイルの種類を「CSV(コンマ区切り)(*.csv)」にしてから、好きな保存先(この例では、デスクトップ)に保存してください。
ファイルの種類は、必ず、「CSV(コンマ区切り)(*.csv)」にしてください。
「CSV UTF-8 (コンマ区切り)(*.csv)」を選んでしまうと、マクロが動作しません。
以上でCSVファイルの準備ができました。
差し込み印刷用ワードファイルの作成
差し込み印刷用のワードファイルは、各自が自由に作成してください。
その際、置換用CSVファイルの一行目の各データ(置換位置目印データ)を、ワードファイル内の置換したい箇所に配置します。
(置換の目印となるデータ(CSVの一行目の各データ)の全角半角大文字小文字は区別されますので注意してください)
例えば、以下のような感じにします(この例では、「★数字」が置換位置目印です)。
以上ですべての準備が整いました。
次に、マクロの実行について説明します。
マクロの実行
1.差し込み印刷用マクロを含むdotmファイルを開きます
(セキュリティ警告が出ますので、「コンテンツの有効化」をクリックしてください
(すべてのワードファイルからマクロを呼び出せるようにした方は、お好きなワードファイルを開いてください)
2.アイコンをクリックします
上の手順で各自が登録したアイコンをクリックします
(以下のイラストでは、手のマークです)
3.メッセージが出るので、「はい」を選択します
4.各自が作成した差し込み印刷用のワードファイルを選択してから、右下のOKボタンを押します
5.各自が作成した置換用CSVファイルを選択してから、右下のOKボタンを押します
OKボタンを押すと、自動で処理が始まります。
6.以下のメッセージが出たら処理終了です
OKボタンを押してメッセージを閉じて下さい
7.印刷用ファイルの確認
印刷用のファイルは、各自が作成した差し込み印刷用ワードファイルと同じフォルダに自動作成されていますので、印刷用ワードファイルのあるフォルダを確認してください。
この例では、「差し込み印刷用ワードファイル.docx」と使用しましたので、同じフォルダ内に「差し込み印刷用ワードファイル_印刷用.docx」が自動作成されます(名前の末尾に「_印刷用」が付きます)。
既に「「差し込み印刷用ワードファイル_印刷用.docx」」がある場合は、上書きは行われずに「差し込み印刷用ワードファイル_印刷用(1).docx」が自動作成されます(末尾に順次数字が付きます)。
8.印刷用ファイルの印刷
置換が正しく行われているかを必ず印刷前に確認してから各自が手動で印刷してください
マクロのキャンセル
マクロの実行中は、以下のイラストのようなフォームが表示されますので、Cancelボタンを押すと処理がキャンセルされます。
マクロを実行中に上のイラストのフォームが表示されていない場合は、画面の一番下のタスクバー上のワードのマークの上にカーソルを持っていき、差し込み印刷マクロを呼び出したワードファイルに表示を切り替えると、上のイラストのフォームが表示されます。
注意点
・CSV作成の際には、半角コンマを含むデータを登録しないように注意してください
CSVファイルはコンマで区切られたファイルなので、おかしな結果を招きます
しかし、金額などのデータを登録する際に、コンマを登録したい方もいるかと思います。
その際は、例えば、データ中の半角コンマを▲などに予め置き換えてからCSVファイルを作成し、マクロによる置換が終わってから、自動作成された印刷用ワードファイル中で◆を手動で半角カンマに置換し直すといいと思います。
・CSVに置換位置目印データを登録する際には、以下の点にご注意ください
例えば、★1と★10を置換位置目印データとして登録した場合、
★10は、★1を含んでおりますので、差し込み印刷用ワードファイル中の★10中の★1部分のみが先に対応データによって置換されてしまいます。
これを回避するには、例えば、10番目の置換位置目印データからは★を使用せず、◆10などにするといいと思います。
マクロの説明は以上です。
コード
現在の公開バージョンはV01L05です。
標準モジュール用コード
以下は、差し込み印刷マクロの標準モジュール用コードです。
上の「マクロの準備」の1で説明したように標準モジュールにコピペしてご使用ください。
(以下のコードをすべて選択して、そのまま貼り付けてください)
説明に戻るにはここをクリックしてください。
Public docCopy As Document
Public strNewFile As String
Sub MailMergeStart()
' V01L05
Dim Response As VbMsgBoxResult
' メッセージボックスを表示し、ユーザーの応答を取得する。
Response = MsgBox("マクロを開始してもよろしいですか?", vbYesNo, "確認")
' ユーザーの応答に基づいてアクションを実行する。
If Response = vbYes Then
WordProcessing
Else
MsgBox "マクロはキャンセルされました。", vbInformation
End If
End Sub
Sub WordProcessing()
Dim strFile As String
Dim strFolder As String
Dim LineNum As Integer
Dim docOriginal As Document
Dim rng As Range
Dim arr1() As String
Dim arrV() As String
Dim csvPass As String
Dim csvFile As Integer
Dim initialPageCount As Integer
Dim middlePageCount As Integer
Dim lastPageCount As Integer
Dim pageCountIncreasement As Integer
Dim secCount As Integer
Dim sec As Section
Dim csvRowCount As Integer
Dim strLine As String
Dim h As Integer
Dim i As Integer
Dim j As Integer
Dim shp As Shape
' 拡張子がdocまたはdocxのファイルのみを選択可能なダイアログボックスを表示する
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "差し込み印刷に使用するワードファイルを選択してください"
.Filters.Clear
.Filters.Add "Word Files", "*.doc; *.docx"
If .Show = -1 Then
strFile = .SelectedItems(1)
Else
Exit Sub ' ユーザーがキャンセルした場合、マクロを終了する
End If
End With
' ユーザーが選択したワードファイルを、「選択ファイル名_印刷用」という名前で、同じフォルダ内にコピーする。
strFolder = Left(strFile, InStrRev(strFile, "\"))
strNewFile = strFolder & Left(Dir(strFile), InStrRev(Dir(strFile), ".") - 1) & "_印刷用.docx"
' 既に同じファイル名のファイルが存在する場合は、さらに末尾に(1)を付けて別ファイルとして保存する。
i = 1
Do While Dir(strNewFile) <> ""
strNewFile = strFolder & Left(Dir(strFile), InStrRev(Dir(strFile), ".") - 1) & "_印刷用(" & i & ").docx"
i = i + 1
Loop
Set docOriginal = Documents.Open(strFile)
docOriginal.SaveAs2 FileName:=strNewFile, FileFormat:=wdFormatXMLDocument
docOriginal.Close SaveChanges:=wdDoNotSaveChanges
' ユーザーにcsvファイルを選択してもらう
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "差し込み印刷に使用するCSVファイルを選択してください"
.Filters.Clear
.Filters.Add "CSV Files", "*.csv"
If .Show = -1 Then
csvPass = .SelectedItems(1)
Else
' csv選択のキャンセル時は、コピーファイルを削除する
On Error Resume Next ' エラーハンドリングを開始
Kill strNewFile ' ファイルを削除
If Err.Number <> 0 Then ' エラーが発生した場合
MsgBox "Error deleting file: " & Err.Description ' エラーメッセージを表示
Err.Clear ' エラーをクリア
End If
On Error GoTo 0 ' エラーハンドリングを終了
Exit Sub ' ユーザーがキャンセルした場合、マクロを終了する
End If
End With
'CSVファイルがUTF-8形式かどうかを判定する
If IsUTF8(csvPass) Then
MsgBox "UTF-8形式のCSVファイルには対応していません" & vbCr & "処理を終了します"
Kill strNewFile ' ファイルを削除
End
End If
' CSVファイル内の行数を取得する。
csvRowCount = 0
csvFile = FreeFile ' 使用可能なファイル番号を取得する。
Open csvPass For Input As csvFile
Do Until EOF(csvFile)
Line Input #csvFile, strLine
csvRowCount = csvRowCount + 1
Loop
Close csvFile
'CSVファイルの行数が2に満たない場合は終了
If csvRowCount < 2 Then
Kill strNewFile ' ファイルを削除
MsgBox "CSVファイルの行数は2行以上である必要があります"
Exit Sub
End If
'フォームを表示
UserForm1.Show vbModeless
UserForm1.Label1.Caption = "処理を開始しました"
'コピーファイルを開く
Set docCopy = Documents.Open(strNewFile)
'ドキュメント内のページ数を取得する。
initialPageCount = docCopy.ComputeStatistics(wdStatisticPages)
'ドキュメント内のセクション数を取得する。
secCount = docCopy.Sections.Count
'ドキュメントが複数のセクションを有する場合は処理を終了する
If secCount > 1 Then
MsgBox "申し訳ございません、複数のセクションを有する文書には対応しておりません"
docCopy.Close SaveChanges:=wdDoNotSaveChanges
Kill strNewFile ' ファイルを削除
End
End If
' 各セクションをコピーし、必要な数(CSVの行数-2)だけ新たなセクションを作成する。
For Each sec In docCopy.Sections
' 現在のセクションの内容を取得する。
sec.Range.Copy
' 文書の最後に改行を付与
docCopy.Content.InsertAfter Text:=vbCr
' 必要な数だけ新たなセクションを作成する。
For j = 1 To csvRowCount - 2
'進行状況をフォームに表示する
UserForm1.Label1.Caption = "新たなセクションを作成中です(" & j & "/" & csvRowCount - 2 & ")"
DoEvents
' 新たなセクション(ページ)を作成する。
docCopy.Range(sec.Range.End - 1, sec.Range.End - 1).InsertBreak Type:=wdSectionBreakNextPage
docCopy.Content.InsertAfter Text:=Chr(12) ' Chr(12)は改ページを表す。
docCopy.Range(sec.Range.Start, sec.Range.End).Paste
Next j
DoEvents
Next sec
'進行状況をフォームに表示する
UserForm1.Label1.Caption = "セクションの作成が終了しました"
' 最後の改行コードを削除する。
Call RemoveLastVbCr(docCopy)
'この時点でのページ数を取得する
middlePageCount = docCopy.ComputeStatistics(wdStatisticPages)
' CSVファイルからデータを読み込むためにファイル番号を取得する。
csvFile = FreeFile
Open csvPass For Input As csvFile
Line Input #csvFile, csvPass ' CSVファイルの最初の行を読み込む
arr1 = Split(csvPass, ",") ' 配列1に格納する
Set rng = Nothing
pageCountIncreasement = 0
For h = 0 To csvRowCount - 2
'進行状況をフォームに表示する
UserForm1.Label1.Caption = "CSVの" & h + 2 & "/" & csvRowCount & "行目を使用して置換中です"
Line Input #csvFile, csvPass ' CSVファイルの次の行を読み込む
arrV = Split(csvPass, ",") ' 配列変数に格納する
docCopy.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=h * initialPageCount + 1 + pageCountIncreasement).Select
'置換開始位置の指定
Set rng = Selection.Range
'置換終了位置の指定
If h <> csvRowCount - 2 Then
docCopy.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=h * initialPageCount + initialPageCount + 1 + pageCountIncreasement).Select
rng.End = Selection.Start
Else
docCopy.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=h * initialPageCount + initialPageCount + pageCountIncreasement).Select
rng.End = docCopy.Content.End
End If
'置換処理
For i = 0 To UBound(arr1)
With rng.Find
.Text = arr1(i)
.Replacement.Text = arrV(i)
.MatchCase = True '大文字と小文字の区別
.MatchByte = True '全角と半角の区別
.MatchWholeWord = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
'テキストボックス内のテキストも置換
For Each shp In docCopy.Range(rng.Start, rng.End).ShapeRange
If shp.Type = msoTextBox Then
With shp.TextFrame.TextRange.Find
.Text = arr1(i)
.Replacement.Text = arrV(i)
.MatchCase = True '大文字と小文字の区別
.MatchByte = True '全角と半角の区別
.MatchWholeWord = True
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
End If
Next shp
'置換後のページの増分を把握する処理
' 最新のドキュメントのページ数を取得する
lastPageCount = docCopy.ComputeStatistics(wdStatisticPages)
'置換後の増分を取得する
pageCountIncreasement = lastPageCount - middlePageCount
'置換範囲に増分を反映させる(選択範囲のお尻を伸ばす)
If h <> csvRowCount - 2 Then
docCopy.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=h * initialPageCount + initialPageCount + 1 + pageCountIncreasement).Select
rng.End = Selection.Start
Else
docCopy.GoTo(What:=wdGoToPage, Which:=wdGoToAbsolute, Count:=h * initialPageCount + initialPageCount + pageCountIncreasement).Select
rng.End = docCopy.Content.End
End If
DoEvents
Next i
DoEvents
Next h
'フォームを非表示
Unload UserForm1
Close csvFile
docCopy.Close SaveChanges:=wdSaveChanges
ClearClipboard
MsgBox "処理が終了しました"
End Sub
Sub CancelProcess()
docCopy.Close SaveChanges:=wdDoNotSaveChanges
Kill strNewFile ' ファイルを削除
End
End Sub
Function IsUTF8(ByVal strPath As String) As Boolean
Dim intFileNum As Integer
Dim bytBOM(2) As Byte
Dim bytUTF8BOM(2) As Byte
bytUTF8BOM(0) = &HEF: bytUTF8BOM(1) = &HBB: bytUTF8BOM(2) = &HBF
intFileNum = FreeFile
Open strPath For Binary Access Read As #intFileNum
Get #intFileNum, , bytBOM
Close #intFileNum
If (bytBOM(0) = bytUTF8BOM(0)) And (bytBOM(1) = bytUTF8BOM(1)) And (bytBOM(2) = bytUTF8BOM(2)) Then
IsUTF8 = True
Else
IsUTF8 = False
End If
End Function
Sub RemoveLastVbCr(doc As Document)
Dim lastChar As Range
Set lastChar = doc.Content
lastChar.Start = lastChar.End - 1
If lastChar.Text = vbCr Then
lastChar.Delete
End If
End Sub
Sub ClearClipboard()
' クリップボードをクリアします
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText ""
.PutInClipboard
End With
End Sub
フォーム用コード
以下は、差し込み印刷マクロのフォーム用コードです。
上の「マクロの準備」の9で説明したようにフォームにコピペしてご使用ください。
(以下のコードをすべて選択して、そのまま貼り付けてください)
説明に戻るには、ここをクリックしてください。
Private Sub CommandButton1_Click()
Unload Me
CancelProcess
End Sub
Private Sub UserForm_Activate()
UserForm1.Caption = "処理中です"
UserForm1.Label1.Font.Size = 12
UserForm1.CommandButton1.Font.Size = 12
UserForm1.CommandButton1.Caption = "Cancel"
End Sub
以上で差し込み印刷マクロの紹介は終わりです。
最後まで読んでいただきましてありがとうございました!
よろしければ、他のマクロも是非見てみてださい!