CSVを基にして差し込み印刷を行うマクロ

こんな方におすすめ

ワードとエクセルの標準の差し込み印刷機能がいまいち分かりにくい！
もっと直感的に差し込み印刷を行いたい！

1 概要
2 詳細説明
3 コード
- 3.1 標準モジュール用コード
- 3.2 フォーム用コード

概要

永久無料サポート付きの中古パソコン　★一見の価値あり★

_{19年の販売実績を持つ老舗です　★価格も安い！★}

このマクロは、CSVファイルのデータを基にしてワードファイル中の任意の場所にデータを挿入するマクロ（差し込み印刷マクロ）です。

年賀状、案内状、送付状などの文書の作成の際に役立つと思います。

以下に、このマクロの概要をイラストで示します。

詳細説明

マクロの準備

１．ワードマクロの実行方法～dotmファイルの作成～に記載したステップ①の１～６までを実施した後、ステップ①の７で、この記事の最後から2つ目にある標準モジュール用コードを標準モジュールのＭodule1にコピペします。

コピペすると、以下の状態になります。

２．「挿入」をクリックして、「ユーザーフォーム」を選択します　

以下の状態になります。

（ツールボックスが表示されていない場合は、「表示」→「ツールボックス」で表示させてください。フォームが表示されなくなった場合は、User Form1をダブルクリックしてください）

３．ツールボックス上の「A」のマークを選択します

４．フォームの上に、ラベルを設置します

　（カーソルをフォームの上に持っていって、左クリックしながら、以下のイラストように広げます）

５．ツールボックス上の「ab」のマークを選択します

６．フォームの上に、コマンドボタンを設置します

　（カーソルをフォームの上に持っていって、左クリックしながら、以下のイラストように広げます）

７．フォーム上に先ほど設置したコマンドボタン（赤丸部分）の上で、ダブルクリックします

以下の状態になります

８．右側に表示されているコードをすべて選択します

選択したコードを消します（以下のイラストの状態にします）

９．この記事の一番最後にあるフォーム用コードを上のイラストの右側の空白部分にコピペします

　コピペすると、以下のイラストの状態になります

１０．ワードマクロの実行方法～dotmファイルの作成～に記載したステップ①の８から２２までを行ってください。

（ステップ①の１１では、「Project.Module1.MailMergeStart」を選択してから、追加ボタンを押してください（以下のイラストのようにしてください））

（ステップ①の１３では、お好きなアイコンを選んでください）

（ステップ①の２０での保存名は何でもいいです）

このマクロをどのワード文書からも呼び出せるようにしたい場合は、ワードマクロの実行方法～dotmファイルの作成～に記載したステップ②も行ってください。

次に、置換用CSVファイルを準備しましょう。

置換用CSVファイルの作成

１．エクセルを開いて、以下のイラストのような感じでデータを登録します

CSVファイルの一行目に、置換位置の目印となるデータを登録します。
置換位置の目印となるデータの半角全角小文字大文字に注意してください。
置換の際には、全角半角小文字大文字が区別されます。
置換用データの登録は二行目から行います。
登録は、A1セルから行ってください。
この例では、全部で4行4列ですが、データの行数と列数に制限はありません。
この例では、一行目に★1～★4が置換位置目印データとして登録されていますが、どのようなデータをどれだけ登録してもかまいません（●でも漢字でもかまいません）。

２．CSVファイルを作成します

　　「ファイル」をクリックします

「名前を付けて保存」をクリックした後、→　「参照」をクリックします

好きな名前を付け（この例では、「置換用CSV」）、ファイルの種類を「CSV(コンマ区切り)(*.csv)」にしてから、好きな保存先（この例では、デスクトップ）に保存してください。

ファイルの種類は、必ず、「CSV(コンマ区切り)(*.csv)」にしてください。

「CSV UTF-8 (コンマ区切り)(*.csv)」を選んでしまうと、マクロが動作しません。

以上でCSVファイルの準備ができました。

永久無料サポート付きの中古パソコン　★一見の価値あり★

_{19年の販売実績を持つ老舗です　★価格も安い！★}

差し込み印刷用ワードファイルの作成

　差し込み印刷用のワードファイルは、各自が自由に作成してください。

　その際、置換用CSVファイルの一行目の各データ（置換位置目印データ）を、ワードファイル内の置換したい箇所に配置します。

　（置換の目印となるデータ（CSVの一行目の各データ）の全角半角大文字小文字は区別されますので注意してください）

例えば、以下のような感じにします（この例では、「★数字」が置換位置目印です）。

以上ですべての準備が整いました。

次に、マクロの実行について説明します。

マクロの実行

１．差し込み印刷用マクロを含むdotmファイルを開きます

　（セキュリティ警告が出ますので、「コンテンツの有効化」をクリックしてください

　（すべてのワードファイルからマクロを呼び出せるようにした方は、お好きなワードファイルを開いてください）

２．アイコンをクリックします

　上の手順で各自が登録したアイコンをクリックします

　（以下のイラストでは、手のマークです）

３．メッセージが出るので、「はい」を選択します

４．各自が作成した差し込み印刷用のワードファイルを選択してから、右下のOKボタンを押します

５．各自が作成した置換用CSVファイルを選択してから、右下のOKボタンを押します

　OKボタンを押すと、自動で処理が始まります。

６．以下のメッセージが出たら処理終了です

　　OKボタンを押してメッセージを閉じて下さい

７．印刷用ファイルの確認

　印刷用のファイルは、各自が作成した差し込み印刷用ワードファイルと同じフォルダに自動作成されていますので、印刷用ワードファイルのあるフォルダを確認してください。

　この例では、「差し込み印刷用ワードファイル.docx」と使用しましたので、同じフォルダ内に「差し込み印刷用ワードファイル_印刷用

.docx」が自動作成されます（名前の末尾に「_印刷用」が付きます）。

　既に「「差し込み印刷用ワードファイル_印刷用.docx」」がある場合は、上書きは行われずに「差し込み印刷用ワードファイル_印刷用(1).docx」が自動作成されます（末尾に順次数字が付きます）。

８．印刷用ファイルの印刷

　置換が正しく行われているかを必ず印刷前に確認してから各自が手動で印刷してください

マクロのキャンセル

　マクロの実行中は、以下のイラストのようなフォームが表示されますので、Cancelボタンを押すと処理がキャンセルされます。

　マクロを実行中に上のイラストのフォームが表示されていない場合は、画面の一番下のタスクバー上のワードのマークの上にカーソルを持っていき、差し込み印刷マクロを呼び出したワードファイルに表示を切り替えると、上のイラストのフォームが表示されます。

注意点

・CSV作成の際には、半角コンマを含むデータを登録しないように注意してください

　CSVファイルはコンマで区切られたファイルなので、おかしな結果を招きます

　しかし、金額などのデータを登録する際に、コンマを登録したい方もいるかと思います。

　その際は、例えば、データ中の半角コンマを▲などに予め置き換えてからCSVファイルを作成し、マクロによる置換が終わってから、自動作成された印刷用ワードファイル中で◆を手動で半角カンマに置換し直すといいと思います。

・CSVに置換位置目印データを登録する際には、以下の点にご注意ください

　例えば、★1と★10を置換位置目印データとして登録した場合、

　★10は、★1を含んでおりますので、差し込み印刷用ワードファイル中の★10中の★1部分のみが先に対応データによって置換されてしまいます。

　これを回避するには、例えば、10番目の置換位置目印データからは★を使用せず、◆10などにするといいと思います。

マクロの説明は以上です。

コード

永久無料サポート付きの中古パソコン　★一見の価値あり★

_{19年の販売実績を持つ老舗です　★価格も安い！★}

現在の公開バージョンはV01L05です。

標準モジュール用コード

以下は、差し込み印刷マクロの標準モジュール用コードです。

上の「マクロの準備」の１で説明したように標準モジュールにコピペしてご使用ください。

（以下のコードをすべて選択して、そのまま貼り付けてください）

説明に戻るにはここをクリックしてください。

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, ",") ' 配列１に格納する
        
    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

フォーム用コード

以下は、差し込み印刷マクロのフォーム用コードです。

上の「マクロの準備」の９で説明したようにフォームにコピペしてご使用ください。

（以下のコードをすべて選択して、そのまま貼り付けてください）

説明に戻るには、ここをクリックしてください。

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

以上で差し込み印刷マクロの紹介は終わりです。

最後まで読んでいただきましてありがとうございました！

他のマクロも是非見て行ってください。

永久無料サポート付きの中古パソコン　★一見の価値あり★

_{19年の販売実績を持つ老舗です　★価格も安い！★}