年末に中学校の同窓会がありました。25年ぶりに会う恩師や友人がいて1次会から話が止まらず盛り上がりました。みんなと連れだって3次会まで参加しました。あっという間に時間が過ぎました。
私は同窓会の受付係を担当しました。申込みをWebの申込みフォームで行い、このデータをExcelファイルにまとめ、当日の名簿や名札を作成しました。これらは今までのイベント（IJET-25）や自主開催セミナーで行っていることと同じことなのでスムーズにいきました。
「Excelファイルから名札」というと、Wordの「差し込み印刷機能」を思い浮かべる方も多いと思います。私は、名札作成には自作マクロを利用しています。というのも、差し込み印刷機能を習得する前にマクロで同じようなものを作ってしまったからです（笑）。
今回の記事では、この名札作成用のマクロを紹介します。シンプルなマクロにしましたが、このマクロは、宛名印刷にも応用できます。「差し込み印刷機能」を覚えるのが面倒な（笑）イベント企画者や幹事の方に活用いただけると思います。表記を自由に変えてご活用ください。
＜目次＞
このマクロでできること
Excelファイルに記載した情報から名刺サイズ（A4で10枚）の名札を作成します。
役職、所属などを記載する1行目と名前を記載する2行目の2つの情報を表示します。
例えば、以下のようなExcelファイルを用意します。なんちゃって個人情報を用いて作りました。
マクロを実行するとExcelファイルを選択するダイアログボックスが表示されます。
ここでExcelファイルを選ぶと、こんな感じの表ができます。2列×5行の表です。市販の名札用紙を利用することを考えて、罫線には色がありません。
フォントのサイズは以下の通りです。好みに応じて変更してください。
マクロの解説
WordからExcelファイルを開きます。事後バインディング（Late Binding）という呼び出し方でExcelオブジェクトを立ち上げて、Excelを操作します。
事後バインディングでExcelオブジェクトを作った場合、Excelのメソッドやプロパティはポップアップのリストで表示されません。また、Excel用の変数（例えば、xlUp, xlDownなど）も使えません。
そういう意味で少し面倒なのですが、事前バインディング（Early Binding）という別の方法をとると、参照設定するライブラリのバージョンによってエラーが発生することがあります。
そのため、私は公開するマクロでは事後バインディングをしています。
マクロ
Sub Excel名簿から名札作成()
Dim ExcelApp As Object
Dim myWorkBook As Object
Dim myWorkSheet As Object
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Dim myFilePath As String 'Excelファイルパス
Dim i As Long
Dim iMax As Long 'Excelファイルの最大行数
Dim RowMax As Integer '名札用紙の最大行数
Dim newDoc As Document '名札用新規ファイル
Dim myTable As Table
Dim myCell As Cell '記入対象のセル
'--------------------------------------------
'Excelファイルの選択
'--------------------------------------------
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
If .Show = -1 Then
myFilePath = .SelectedItems(1)
Else
Exit Sub
End If
End With
Select Case Right(myFilePath, 4)
Case ".xls", "xlsx"
'何もしない
Case Else
MsgBox "Excelファイルを選択してください。"
Exit Sub
End Select
Set fd = Nothing
Application.ScreenUpdating = False
'--------------------------------------------
'Excelファイルを開く
'--------------------------------------------
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
Set myWorkBook = ExcelApp.workbooks.Open(myFilePath)
Set myWorkSheet = myWorkBook.worksheets(1)
'ExcelファイルのA列の最終行を取得（-4162はxlUp）
iMax = myWorkSheet.Cells(myWorkSheet.Rows.Count, 1).End(-4162).Row
'--------------------------------------------
'用紙の設定（縦55mm、横91mmのA4の10面名刺サイズ）
'--------------------------------------------
Set newDoc = Documents.Add
'行数の設定
RowMax = Round((iMax - 1) / 2)
'フォント設定
With newDoc.Range.Font
.NameFarEast = "ＭＳ ゴシック"
.NameAscii = "Arial"
.NameOther = "Arial"
.Name = "Arial"
.Size = 10.5
End With
'余白設定
With newDoc.PageSetup
.TopMargin = MillimetersToPoints(11)
.BottomMargin = MillimetersToPoints(6)
.LeftMargin = MillimetersToPoints(14)
.RightMargin = MillimetersToPoints(14)
.LinesPage = 53
.LayoutMode = wdLayoutModeLineGrid
End With
'表の作成
Set myTable = newDoc.Tables.Add(newDoc.Range, RowMax, 2)
With myTable
.Rows.HeightRule = wdRowHeightExactly
.Rows.Alignment = wdAlignRowCenter
.Rows.Height = MillimetersToPoints(55)
.Columns.Width = MillimetersToPoints(91)
.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
End With
'--------------------------------------------
'書き込み
'--------------------------------------------
With myWorkSheet
For i = 2 To iMax
'書き込み対象のセルオブジェクトの設定
Set myCell = myTable.Cell(Int(i / 2), i Mod 2 + 1)
'下の列（名前）
With myCell.Range.Paragraphs(1).Range
.Font.Size = 34 'フォントサイズ
.InsertParagraphBefore
.ParagraphFormat.Alignment = wdAlignParagraphCenter '中央揃え
.InsertBefore Text:=myWorkSheet.Cells(i, 2).Value
.InsertParagraphBefore
End With
'上の列（都道府県）
With myCell.Range.Paragraphs(1).Range
.Font.Size = 22 'フォントサイズ
.InsertParagraphBefore
.ParagraphFormat.Alignment = wdAlignParagraphLeft '左揃え
.InsertBefore Text:=myWorkSheet.Cells(i, 3).Value
End With
DoEvents
Next i
End With
'--------------------------------------------
'後処理
'--------------------------------------------
'Excelファイルを閉じる
myWorkBook.Close
DoEvents
'処理後のExcelオブジェクトの解放部分
Set myWorkBook = Nothing
Set myWorkSheet = Nothing
ExcelApp.Quit
DoEvents
Set ExcelApp = Nothing
Set newDoc = Nothing
Set myTable = Nothing
Application.ScreenUpdating = True
DoEvents
MsgBox iMax - 1 & "名の名札を作成しました。"
End Sub
