'アクティブシートを段組みにするマクロ

'セルを選択し、FormatSectionColumn マクロを実行してください。

Option Explicit

Private Const sAppName = "段組みフォーマット"

Sub FormatSectionColumn()
    Dim oRange_Input As Range
    Dim oRange_Output As Range
    Dim iPageRowCount As Long
    Dim iPageColumnCount As Long
    Dim iHeaderRowCount As Long
    Dim iBodyRowCount As Long
    Dim iLastRow As Long
    Dim iColumnCount As Long
    Dim iRow_Input As Long
    Dim iRow_Output As Long
    Dim iColumn_Output As Long
    Dim iSectionColumn As Long
    Dim iPage As Long
    Dim iCopyRowCount As Long
    Dim sDefault As String
    Dim bPrintTitleRows As Boolean
    Dim vRet As Variant

    '対象範囲のデフォルト値を取得。
    If TypeName(Selection) = "Range" Then
        If Selection.Cells.Count = 1 Then
            Selection.CurrentRegion.Select
        End If
        sDefault = Selection.Areas(1).Address
    Else
        sDefault = ""
    End If

    '対象範囲の取得。
    Set oRange_Input = InputBoxRange("セル範囲を選択してください。", sAppName, sDefault)
    If oRange_Input Is Nothing Then Exit Sub
    Set oRange_Input = oRange_Input.Areas(1)
    Set oRange_Input = Application.Intersect(oRange_Input.Worksheet.UsedRange, oRange_Input)
    If oRange_Input Is Nothing Then
        MsgBox "データがありません。", vbExclamation, sAppName
        Exit Sub
    End If

    '1ページの行数の取得。
    vRet = Application.InputBox(Prompt:="1ページの行数を入力してください。", _
        Title:=sAppName, Type:=1)
    If VarType(vRet) = vbBoolean Then Exit Sub
    iPageRowCount = vRet

    '1ページの段組み数の取得。
    vRet = Application.InputBox(Prompt:="1ページの段組み数を入力してください。", _
        Title:=sAppName, Type:=1)
    If VarType(vRet) = vbBoolean Then Exit Sub
    iPageColumnCount = vRet

    '見出し行数の取得。
    vRet = Application.InputBox(Prompt:="見出し行の行数を入力してください。", _
        Title:=sAppName, Type:=1)
    If VarType(vRet) = vbBoolean Then Exit Sub
    iHeaderRowCount = vRet


    'データ最終行と列数の設定
    iLastRow = oRange_Input.Rows.Count
    iColumnCount = oRange_Input.Columns.Count
    iBodyRowCount = iPageRowCount - iHeaderRowCount

    If (iPageRowCount < 1) Or (iHeaderRowCount < 0) Or (iPageColumnCount < 1) _
            Or (iBodyRowCount < 1) Then
        MsgBox "入力データが不正です。", vbExclamation, sAppName
        Exit Sub
    End If

    If iLastRow < iHeaderRowCount Then
        MsgBox "データがありません。", vbExclamation, sAppName
        Exit Sub
    End If

    '行のタイトルの設定。
    If iHeaderRowCount > 0 Then
        vRet = MsgBox("ページ設定の[行のタイトル]を設定しますか?", _
            vbQuestion Or vbYesNoCancel, sAppName)
        Select Case vRet
            Case vbYes
                bPrintTitleRows = True
            Case vbNo
                bPrintTitleRows = False
            Case Else
                Exit Sub
        End Select
    Else
        bPrintTitleRows = False
    End If

    Set oRange_Output = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(1, 1)

    oRange_Output.Worksheet.Cells.PageBreak = xlNone

    If bPrintTitleRows Then

        '見出し行のコピーと行のタイトルの設定。
        With oRange_Input.Rows(1).Resize(iHeaderRowCount)
            oRange_Output.Worksheet.PageSetup.PrintTitleRows = .Address
            .Copy
        End With
        For iSectionColumn = 1 To iPageColumnCount
            iColumn_Output = (iColumnCount + 1) * (iSectionColumn - 1) + 1
            With oRange_Output.Cells(1, iColumn_Output)
                .PasteSpecial xlValues
                .PasteSpecial xlFormats
            End With
        Next

        '行カウンタの初期化。
        iRow_Input = iHeaderRowCount + 1
        iRow_Output = iHeaderRowCount + 1
        iPageRowCount = iBodyRowCount
        iHeaderRowCount = 0

    Else

        '行カウンタの初期化。
        iRow_Input = iHeaderRowCount + 1
        iRow_Output = 1
    End If

    'ページカウンタと段カウンタの初期化。
    iPage = 1
    iSectionColumn = 1

    Do While iRow_Input <= iLastRow
        'コピー行数の取得。
        If iRow_Input + iBodyRowCount <= iLastRow Then
            iCopyRowCount = iBodyRowCount
        Else
            iCopyRowCount = iLastRow - iRow_Input + 1
        End If
        
        '貼り付け先の列番号の取得。
        iColumn_Output = (iColumnCount + 1) * (iSectionColumn - 1) + 1

        '列見出しのコピー
        If iHeaderRowCount > 0 Then
            oRange_Input.Rows(1).Resize(iHeaderRowCount).Copy
            With oRange_Output.Cells(iRow_Output, iColumn_Output)
                .PasteSpecial xlValues
                .PasteSpecial xlFormats
            End With
        End If

        '1段のデータ範囲のコピー
        oRange_Input.Cells(iRow_Input, 1).Resize(iCopyRowCount, iColumnCount).Copy
        With oRange_Output.Cells(iRow_Output + iHeaderRowCount, iColumn_Output)
            .PasteSpecial xlValues
            .PasteSpecial xlFormats
        End With


        '改ページの設定。
        If iSectionColumn = 1 Then
            If iPage > 1 Then
                oRange_Output.Rows(iRow_Output).EntireRow.PageBreak = xlManual
            End If
        End If
        
        'カウンタの更新。
        If iSectionColumn < iPageColumnCount Then
            iSectionColumn = iSectionColumn + 1
        Else
            iPage = iPage + 1
            iSectionColumn = 1
            iRow_Output = iRow_Output + iPageRowCount
        End If
        iRow_Input = iRow_Input + iBodyRowCount
    Loop
End Sub


'セル範囲を入力する関数
Function InputBoxRange(sPrompt As String, sTitle As String, _
        sDefault As String) As Range
    On Error Resume Next
    Set InputBoxRange = Application.InputBox( _
        Prompt:=sPrompt, Title:=sTitle, default:=sDefault, Type:=8)
End Function


'テスト用マクロ

Sub Test_FormatSectionColumn()

    'テスト用シートの作成
    Workbooks.Add xlWorksheet
    Cells.Clear
    Range("A1:B1").Value = Array("Field1", "Field2")
    Range("A2:B2").Value = Array(1, "Item1")
    Range("A2").DataSeries Rowcol:=xlColumns, _
        Type:=xlLinear, Step:=1, Stop:=200
    Range("B2").AutoFill Destination:=Range("B2:B201")

    FormatSectionColumn

    ActiveSheet.PrintPreview
End Sub