'ラベル印刷マクロ

'1. 印刷用シートの準備
' 1.1 1 ページ分のシートを作成し、セル書式の設定やページ設定をします。
'     マクロはこのシートをコピーして使います。
' 1.2 1 ページの範囲に Page という名前を定義します。
' 1.3 左上のラベルの範囲に Label という名前を定義します。
'     単票印刷のときは Page 範囲と同じ範囲にします。
' 1.4 データを転記したいセルには $フィールド名 と記入します。
'     このフィールド定義は Label 範囲内だけで構いません。

'2. 印刷用データの準備
' 2.1 印刷するリストデータを用意してください。
' 2.2 リストデータの範囲に LabelData という名前を定義します。
'     範囲は自動拡張されるので、左上の一つのセルだけでも構いません。
'     リストデータが別のブックにある場合は、印刷用シートを選択した状態で
'     [挿入]-[名前定義]を実行し、LabelData という名前を定義してください。
' 2.3 LabelData 範囲の 1 行目はフィールド名です。
'     Label 範囲のフィールド名と一致させてください。（先頭の$は不要です）
' 2.4 必要に応じてフィルタをしてください。非表示行は転記しません。

'3. マクロの準備
' 3.1 このマクロはデータと同じブックに作成する必要はありません。
' 3.2 [ツール]-[マクロ]-[Visual Basic Editor] を実行。
' 3.3 「プロジェクト」ウィンドウでマクロを作りたいブックを選択します。
'     ( )内がブック名です。Book1.xls の場合は「VBAProject (Book1.xls)」などです。
' 3.4 [挿入]-[標準モジュール]を実行。
' 3.5 「Book1.xls - Module1 (コード)」というようなウィンドウが開きます。
' 3.6 このマクロ全体（この説明書き等もすべて含めて）をコピー貼り付けします。
'     Option Explicit という行があるときは、必ずその下に貼り付けて下さい。
' 3.7 エクセルに戻り、印刷用シートを選択した状態で、[ツール]-[マクロ]-[マクロ]
'     「ラベル印刷用シート作成」マクロを実行します。
' 3.8 作成されたシートを確認し、印刷します。

'4. マクロの削除
' 4.1 マクロの削除は、「プロジェクト」ウィンドウで削除したいモジュールを選択し
'     [ファイル]-[Module1 の解放]（Module1 の部分は変化します）を実行します。
'     確認のダイアログボックスが表示されますが、エクスポートする必要はありません。


Private Const DataName = "LabelData"
Private Const PageName = "Page"
Private Const LabelName = "Label"
Private Const WorkName = "WorkColumn"
Private Const FieldPrefix = "$"
Private Const CopyDirection = 0 '0: 列方向優先, 1: 行方向優先
Private Const NewWorkbook = 1   '0: 同ブックにシートを作成, 1: 新規ブックを作成

Sub ラベル印刷用シート作成()
    Dim DataRange As Range
    Dim PageRange As Range
    Dim LabelRange As Range
    Dim CurrentLabel As Range
    Dim LabelRow As Long
    Dim LabelCol As Long
    Dim RowCount As Long
    Dim ColCount As Long
    Dim PageCount As Long
    Dim LabelCount As Long
    Dim Fields() As Variant
    Dim FieldCount As Long
    Dim FieldName As String
    Dim c As Range
    Dim i As Long
    Dim j As Long

    '各範囲の取得
    On Error Resume Next
    Set PageRange = Range(PageName)
    Set LabelRange = Range(LabelName)
    Set DataRange = Range(DataName).CurrentRegion
    On Error GoTo 0

    On Error GoTo ErrorHandler
    If PageRange Is Nothing Then
        MsgBox "範囲名(" & PageName & ")が定義されていません。", vbExclamation
        Exit Sub
    End If
    If LabelRange Is Nothing Then
        MsgBox "範囲名(" & LabelName & ")が定義されていません。", vbExclamation
        Exit Sub
    End If
    If DataRange Is Nothing Then
        MsgBox "範囲名(" & DataName & ")が定義されていません。", vbExclamation
        Exit Sub
    End If
    If PageRange.Rows.Count Mod LabelRange.Rows.Count <> 0 Then
        MsgBox "ページ範囲とラベル範囲の行数が合っていません。", vbExclamation
        Exit Sub
    End If
    If PageRange.Columns.Count Mod LabelRange.Columns.Count <> 0 Then
        MsgBox "ページ範囲とラベル範囲の列数が合っていません。", vbExclamation
        Exit Sub
    End If

    Application.ScreenUpdating = False

    'ラベルの行数等
    LabelRow = LabelRange.Rows.Count
    LabelCol = LabelRange.Columns.Count
    RowCount = PageRange.Rows.Count \ LabelRow
    ColCount = PageRange.Columns.Count \ LabelCol
    PageCount = RowCount * ColCount

    'フィールド情報の取得
    For Each c In LabelRange.Cells
        If Left(c.Formula, 1) = FieldPrefix Then
            FieldName = Mid(c.Formula, 2)
            For i = 1 To DataRange.Columns.Count
                If DataRange.Cells(1, i).Value = FieldName Then
                    FieldCount = FieldCount + 1
                    ReDim Preserve Fields(1 To FieldCount)
                    Fields(FieldCount) = Array(i, _
                        c.Row - LabelRange.Row + 1, _
                        c.Column - LabelRange.Column + 1)
                    Exit For
                End If
            Next
        End If
    Next

    'シートをコピー
    If NewWorkbook = 0 Then
        PageRange.Worksheet.Copy after:=PageRange.Worksheet
    Else
        PageRange.Worksheet.Copy
    End If

    '作業用範囲が定義されていればクリアする
    On Error Resume Next
    Application.Intersect(ActiveSheet.Range(WorkName), ActiveSheet.Cells).Clear
    On Error GoTo ErrorHandler

    Set LabelRange = ActiveSheet.Range(LabelRange.Address)
    LabelCount = 0
    For i = 2 To DataRange.Rows.Count
        'リストの非表示行はコピーしない
        If DataRange.Rows(i).Height > 0 Then
            'ラベルのセル範囲を決定
            If CopyDirection = 0 Then j = ColCount Else j = RowCount
            Set CurrentLabel = LabelRange.Offset( _
                (LabelCount \ j) * LabelRow, (LabelCount Mod j) * LabelCol)
            'ページ先頭のラベルのとき、1 ページ分をコピー
            If (LabelCount Mod PageCount = 0) And (LabelCount > 0) Then
                PageRange.EntireRow.Copy CurrentLabel.Cells(1).EntireRow
                CurrentLabel.Cells(1).EntireRow.PageBreak = xlManual
                ActiveSheet.DisplayPageBreaks = False
            End If
            'フィールドデータをコピー
            For j = 1 To FieldCount
                DataRange.Cells(i, Fields(j)(0)).Copy
                CurrentLabel.Cells(Fields(j)(1), Fields(j)(2)).PasteSpecial xlValues
            Next
            LabelCount = LabelCount + 1
        End If
    Next

    'データのないラベルをクリア
    Do While LabelCount Mod PageCount > 0
        If CopyDirection = 0 Then j = ColCount Else j = RowCount
        Set CurrentLabel = LabelRange.Offset( _
            (LabelCount \ j) * LabelRow, (LabelCount Mod j) * LabelCol)
        CurrentLabel.Clear
        LabelCount = LabelCount + 1
    Loop

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Exit Sub

ErrorHandler:
    MsgBox Error(Err), vbExclamation
End Sub


Sub ラベル範囲をページ全体にコピー()
    Dim DataRange As Range
    Dim PageRange As Range
    Dim LabelRange As Range
    
    On Error Resume Next
    Set PageRange = Range(PageName)
    Set LabelRange = Range(LabelName)
    Set DataRange = Range(DataName).CurrentRegion
    On Error GoTo 0
    
    On Error GoTo ErrorHandler
    If PageRange Is Nothing Then
        MsgBox "範囲名(" & PageName & ")が定義されていません。", vbExclamation
        Exit Sub
    End If
    If LabelRange Is Nothing Then
        MsgBox "範囲名(" & LabelName & ")が定義されていません。", vbExclamation
        Exit Sub
    End If
    If DataRange Is Nothing Then
        MsgBox "範囲名(" & DataName & ")が定義されていません。", vbExclamation
        Exit Sub
    End If

    If PageRange.Rows.Count Mod LabelRange.Rows.Count <> 0 Then
        MsgBox "ページ範囲とラベル範囲の行数が合っていません。", vbExclamation
        Exit Sub
    End If
    If PageRange.Columns.Count Mod LabelRange.Columns.Count <> 0 Then
        MsgBox "ページ範囲とラベル範囲の列数が合っていません。", vbExclamation
        Exit Sub
    End If
    LabelRange.Copy
    PageRange.PasteSpecial
    Application.CutCopyMode = False
    Exit Sub

ErrorHandler:
    MsgBox Error(Err), vbExclamation
End Sub