シート内のリストから差し込み印刷ラベルを作る

元々VBAからWordを呼び出して、値渡し→ラベルレイアウト…と考えていたんですけどそれは結構難易度が高く、業務用にちゃちゃっとプログラミングというわけに行かなかったのでちょろっと調べてみました。

まずはWordでマクロ記録をしてみたんですが、差し込み印刷関係が記録されないので、この辺のメソッドやらプロパティを調べるのはもう止めました。だってもっと簡単な方法あるから。

1. データソースと差し込み印刷設定済みWordファイルを固定ディレクトリに配置しておく
2. データソースに表示データを上書き
3. Wordファイルを呼び出す

処理としてはこれだけ。ファイルを生成しないので設定あるいはメンテナンスのひと手間がありますが、例えば次の担当者が使いたいと言った時の敷居が低いのもこれかなと。

まあこれだけ書けばコード書ける人には説明不要でしょうけど、一応続き以降にサンプルコードを載せておきます。




※マクロ実行ファイル(Excel)、差し込み用データソース(TXT)、差し込み実行ファイル(Word)はそれぞれ同一ディレクトリ内に配置しておきます。

データ掃き出し処理がこちら。

====
Sub Save_Address()
On Error GoTo Err_

 Const f As String = "¥作業用ファイル.txt"
 Dim myPath As String
 Dim buf As String　　　　　　　　　'データの入れ物
 Dim r As Integer, c As Integer　'行/列用カウンタ
 Dim EndRow As Long　　　　　　　　'最終行

 myPath = ActiveWorkbook.Path　　'作業フォルダのディレクトリ取得

With ActiveSheet
  EndRow = Cells(65536,1).End(xlUp).Row

  For r = 1 To EndRow
   If Cells(r,1) <> "" Then
    For c = 1 To 5
     buf = buf & .Cells(r,c)
     If c < 5 Then buf = buf & vbTab  '※1
    Next
     buf = buf & vbCrLf
   End If
  Next
End With

Open myPath & f For Output As #1 ’上書きモードで開く
Print #1, buf

End_l:  Close #1
             Exit Sub

Err_:    MsgBox Err.Number & ":" & Err.Description
             Resume End_
End Sub
====

で、このプロシージャとWordを順に呼び出すのがこちら。

====
Sub Call_DataAndLabels()
On Error Goto Err2_

 Dim ret As Integer  '戻り値判定用

 Call Save_Address

 With CreateObject("Wscript.Shell")

  ret = .Run("C:¥Hoge¥差し込みラベル.docx", 5, True)  'Word呼出(パラメータは"おまじない")

  If ret <> 0 Then GoTo Err2_　'戻り値が0以外はエラー
 End With
 MsgBox "処理が完了しました", vbOKOnly

End2_:  Exit Sub

Err2_:  MsgBox Err.Number & ":" & Err.Desctription
             GoTo End2_
End Sub
====

こんなところです。TXTファイルを使っているのは、CSVの場合データに桁区切りカンマ(',')があるとフィールド数を正しく認識できないからです。でタブ区切りにするため「vbTab」なんてものを使ってる。便利ですねえ…(遠い目) それと最後のフィールドの時は改行コードを入れています。これやらないと1行のテキストになっちゃうので。

あとはWSHで呼び出したWordが正常終了したらメッセージを表示しています。親切でしょ(要らなきゃ消してね)。