'宛名ラベル印刷サンプルマクロ

'* カスタマイズについての解説 *

'このマクロはページ設定済みの印刷用シートを必要な枚数コピーし、データを転記、
'印刷プレビューします。

'印刷用シートの名前は、定数TemplateSheetNameで設定してください。

'「ブロック」とはラベル1枚分のセル範囲のことです。
'各ブロックの間は1行1列の間隔を空けてください。
'ブロックの開始行、開始列、行数、列数、ページ当たりのブロック数を
'各定数で設定してください。

'データ範囲は「ラベル印刷マクロ MyLabelPrint()」の「データ範囲の取得」で、
'見出し行を含めない範囲を変数range1に設定してください。
'サンプルのMyLabelPrint()では、アクティブシートのA1を基点としてデータが
'連続している範囲、ただし1行目は項目見出し行、という設定になっています。
'同じ条件であれば変更は不要です。

'転記処理は「ラベル用データを転記するマクロ MyEditLabelData()」で行います。
'range1はデータ行、range2はラベル用範囲の左上隅セルが設定されます。
'実際のデータやラベルのフォーマットに合わせて変更してください。


'Testマクロを実行するとサンプルが作成されます。


Option Explicit

'印刷用シートの名前
Const TemplateSheetName = "宛名ラベル1"

'ブロックの開始行
Const startRow = 3

'ブロックの開始列
Const startColumn = 2

'ブロックの行数
Const blockRows = 10

'ブロックの列数
Const blockColumns = 2

'1ページの行方向のブロック数
Const blockCountRow = 6

'1ページの列方向のブロック数
Const blockCountColumn = 2

'テスト実行用マクロ
Sub Test()
    On Error Resume Next
    Sheets(TemplateSheetName).Select
    If Err <> 0 Then MakeLabelSheet
    MakeSampleSheet
    MyLabelPrint
End Sub

'ラベル印刷マクロ
Sub MyLabelPrint()
    Const myTitle As String = "宛名ラベル印刷"
    Dim templateSheet As Worksheet, outputSheet As Worksheet
    Dim outputBook As Workbook
    Dim r1 As Range, r2 As Range, range1 As Range
    Dim blockCount As Integer, blockNo As Integer
    Dim dataCount As Integer, pageCount As Integer
    Dim sheetIndex As Integer
    Dim i As Integer
    Dim obj As Object

    'データ範囲の取得
    '変数range1にデータ範囲を設定します。
    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    With ActiveSheet.Cells(1, 1).CurrentRegion
        dataCount = .Rows.Count - 1
        If dataCount = 0 Then
            MsgBox "印刷データがありません。", vbExclamation, myTitle
            Exit Sub
        Else
            Set range1 = .Resize(dataCount).Offset(1)
        End If
    End With

    '印刷用シートの取得
    Set templateSheet = Nothing
    For Each obj In ActiveWorkbook.Worksheets
        If obj.Name = TemplateSheetName Then
            Set templateSheet = obj
            Exit For
        End If
    Next

    If templateSheet Is Nothing Then
        MsgBox "印刷用テンプレートシートがありません。", vbExclamation, myTitle
        Exit Sub
    End If

    Application.ScreenUpdating = False

    '印刷用シートのコピー
    blockCount = blockCountRow * blockCountColumn
    pageCount = (dataCount + blockCount - 1) \ blockCount
    templateSheet.Copy
    For i = 2 To pageCount
        templateSheet.Copy after:=ActiveSheet
    Next

    '印刷用ブックの取得
    Set outputBook = ActiveWorkbook

    '印刷用ブックの作成
    blockNo = blockCount - 1
    sheetIndex = 0
    For Each r1 In range1.Rows

        'ブロック番号の更新
        blockNo = blockNo + 1
        If blockNo = blockCount Then
            blockNo = 0
            sheetIndex = sheetIndex + 1
            Set outputSheet = outputBook.Worksheets(sheetIndex)
        End If

        '出力セル位置の取得
        Set r2 = outputSheet.Cells( _
            startRow + blockRows * (blockNo \ blockCountColumn), _
            startColumn + blockColumns * (blockNo Mod blockCountColumn))

        '転記
        MyEditLabelData r1, r2
    Next

    '印刷プレビュー
    ActiveWorkbook.Worksheets.Select
    Application.ScreenUpdating = True
    ActiveWindow.SelectedSheets.PrintPreview 'Out From:=1, To:=1, Copies:=1
End Sub


'ラベル用データを転記するマクロ

'range1はデータ行、range2はラベル1枚のセル範囲の左上隅セルが設定されます。

Sub MyEditLabelData(range1 As Range, range2 As Range)
    range2.Cells(1, 1).Value = "〒" & range1.Cells(1, 8).Value
    range2.Cells(2, 1).Value = range1.Cells(1, 9).Value
    range2.Cells(3, 1).Value = range1.Cells(1, 10).Value
    range2.Cells(5, 1).Value = range1.Cells(1, 4).Value
    range2.Cells(6, 1).Value = range1.Cells(1, 6).Value
    range2.Cells(7, 1).Value = range1.Cells(1, 7).Value
    range2.Cells(9, 1).Value = range1.Cells(1, 2).Value & "  様"
End Sub


'ラベル印刷用シートを作成するマクロ
Sub MakeLabelSheet()
    Dim widthBase As Double, width1 As Double, width2 As Double
    Dim r As Range
    Dim i As Integer
    Application.ScreenUpdating = False
    Worksheets.Add
    With ActiveSheet
        .Name = TemplateSheetName
        .Cells.NumberFormat = "@"
        .Cells.Font.Name = "ＭＳ Ｐ明朝"
        .Cells.Font.Size = 9
        .Rows(1).RowHeight = 9
        For i = 2 To 52 Step 10
            .Rows(i).RowHeight = 21.9
            .Rows(i + 1).Resize(7).RowHeight = 11.4
            .Rows(i + 8).RowHeight = 9.9
            .Rows(i + 9).RowHeight = 14.4
            .Rows(i + 9).Font.Size = 12
        Next
        Set r = .Cells(1, 1)
        widthBase = GetWidthBase(r)
        width1 = ColumnWidthToWidth(r, 1)
        width2 = ColumnWidthToWidth(r, 2)
        .Columns(1).ColumnWidth = WidthToColumnWidth2( _
            24, widthBase, width1, width2)
        .Columns(2).ColumnWidth = WidthToColumnWidth2( _
            211.2, widthBase, width1, width2)
        .Columns(3).ColumnWidth = WidthToColumnWidth2( _
             24.6, widthBase, width1, width2)
        .Columns(4).ColumnWidth = WidthToColumnWidth2( _
            211.2, widthBase, width1, width2)
    End With

    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = 56.7
        .RightMargin = 28.35
        .TopMargin = 36.85
        .BottomMargin = 36.85
        .HeaderMargin = 36.85
        .FooterMargin = 36.85
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintNotes = False
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = True
        .Zoom = 100
    End With
End Sub

'試行により、セル幅の基準値を取得する関数
Function GetWidthBase(range1 As Range) As Double
    Dim w0 As Double, w As Double
    w0 = range1.ColumnWidth
    range1.ColumnWidth = 0
    w = 0
    Do While True
        w = w + 0.001
        range1.ColumnWidth = w
        If range1.ColumnWidth > 0 Then
            GetWidthBase = range1.Width
            range1.ColumnWidth = w0
            Exit Do
        End If
    Loop
End Function

'試行により、ColumnWidthをWidthに変換する関数
Function ColumnWidthToWidth(range1 As Range, _
        columnWidth1 As Double) As Double
    Dim w As Double
    w = range1.ColumnWidth
    range1.ColumnWidth = columnWidth1
    ColumnWidthToWidth = range1.Width
    range1.ColumnWidth = w
End Function


'WidthをColumnWidthに変換する関数
Function WidthToColumnWidth2(cellWidth As Double, _
        widthBase As Double, width1 As Double, width2 As Double _
        ) As Double
    Dim cellWidthCount As Integer
    Dim widthCount1 As Integer, widthCount2 As Integer

    cellWidthCount = Int(cellWidth / widthBase + 0.0001)
    widthCount1 = Int(width1 / widthBase + 0.0001)
    widthCount2 = Int((width2 - width1) / widthBase + 0.0001)

    If cellWidthCount <= widthCount1 Then
        WidthToColumnWidth2 = CDbl(Format((cellWidthCount / widthCount1) * 100, "0")) / 100
    Else
        WidthToColumnWidth2 = CDbl(Format( _
            (((cellWidthCount - widthCount1) / widthCount2) + 1) * 100, "0")) / 100
    End If
End Function


'テストデータを作成するマクロ
Sub MakeSampleSheet()
    Worksheets.Add
    Range("A1:N1").Value = Array("番号", "氏名", "氏名かな", "会社名", _
        "会社名かな", "所属", "役職", "郵便番号", "住所1", "住所2", _
        "電話番号", "FAX番号", "日付", "備考")
    Range("A2:N2").Value = Array(101, "名前 名前1", "なまえ なまえ1", _
        "株式会社 会社名会社名1", "かいしゃめい1", "営業部", "課長", _
        "123-0001", "県県県郡郡郡町町町１−１２−１００１", _
        "ビルビルビル１Ｆ", "XXXX-XX-0001", "XXXX-XX-0001", "98/01/19", "")
    Range("A2:M2").AutoFill Destination:=Range("A2:M200")
End Sub