'各行に見出し行を追加するマクロ

'例えば以下のように表を変形します。

'      A      B      C
' 1  項目1  項目2  項目3
' 2    100     10     10
' 3    200     20     20
' 4    300     30     30

'      A      B      C
' 1  項目1  項目2  項目3
' 2    100     10     10
' 3
' 4  項目1  項目2  項目3
' 5    200     20     20
' 6
' 7  項目1  項目2  項目3
' 8    300     30     30
' 9

'値、書式、列幅、行高をコピーしています。

'表のあるシートを選択し、MyHeaderAddマクロを実行してください。


Option Explicit

'各行に見出し行を追加するマクロ
Sub MyHeaderAdd()
    Const myTitle As String = "各行に項目見出しを追加する"
    Dim oRange_Input As Range
    Dim oRange_Output As Range
    Dim iRet As Long

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub

    '画面の更新を抑止
    Application.ScreenUpdating = False

    'アクティブシートのデータ範囲を取得
    Set oRange_Input = ActiveSheet.Cells(1, 1).CurrentRegion

    '出力用シートの作成
    Set oRange_Output = Workbooks.Add(xlWorksheet).Worksheets(1).Cells(1, 1)

    '既存のブックをテンプレートとして使う場合は、xlWorksheetの代わりに
    'ファイル名を指定します。
    'Set oRange_Output = Workbooks.Add("D:\Work\Kojin.xls").Worksheets(1).Cells(1, 1)

    '出力用シートの値をクリア
    oRange_Output.Worksheet.Cells.ClearContents

    'コピーの実行
    iRet = MyHeaderAdd2( _
        oRange_Input:=oRange_Input, _
        oRange_Output:=oRange_Output, _
        iHeaderRowCount:=1, _
        iBodyRowCount:=1, _
        iSpaceRowCount:=1)

    'クリップボードのクリア
    Application.CutCopyMode = False

    '画面の更新
    Application.ScreenUpdating = True

    Select Case iRet
        Case -1
            MsgBox "データがありません。", vbExclamation, myTitle
        Case 0
        Case Else
            MsgBox Error(iRet) & " (" & Err & ")", vbExclamation, myTitle
    End Select
End Sub


'各行をコピーするマクロ

'    oRange_Input    : コピー元範囲 
'    oRange_Output   : コピー先範囲
'    iHeaderRowCount : 見出し行数
'    iBodyRowCount   : 1回にコピーするデータ行数
'    iSpaceRowCount  : 間隔行数

Function MyHeaderAdd2( _
        oRange_Input As Range, _
        oRange_Output As Range, _
        iHeaderRowCount As Integer, _
        iBodyRowCount As Integer, _
        iSpaceRowCount As Integer) As Integer

    Dim oRange_Header As Range
    Dim oRange_Output2 As Range
    Dim iRowCount As Integer
    Dim iOffset As Integer
    Dim i As Integer

    On Error GoTo err_1

    '見出し行だけのときは中断する
    iRowCount = oRange_Input.Rows.Count
    If iRowCount <= iHeaderRowCount Then
        MyHeaderAdd2 = -1
        Exit Function
    End If

    '貼り付け行間隔の設定
    iOffset = iHeaderRowCount + iBodyRowCount + iSpaceRowCount

    '見出し行範囲の取得
    Set oRange_Header = oRange_Input.Resize(iHeaderRowCount)

    '出力先の設定
    Set oRange_Output2 = oRange_Output.Cells(1, 1)

    For i = iHeaderRowCount + 1 To iRowCount Step iBodyRowCount

        '見出し行のコピー
        MyCopyPaste oRange_Header, oRange_Output2

        'データ行のコピー
        MyCopyPaste oRange_Input.Rows(i).Resize(iBodyRowCount), _
            oRange_Output2.Offset(iHeaderRowCount)

        '出力位置の更新
        Set oRange_Output2 = oRange_Output2.Offset(iOffset)
    Next

    '列幅のコピー
    For i = 1 To oRange_Input.Columns.Count
        oRange_Output.Cells(1, i).ColumnWidth _
            = oRange_Input.Columns(i).ColumnWidth
    Next

    MyHeaderAdd2 = 0
    Exit Function
err_1:
    MyHeaderAdd2 = Err
End Function


'コピー貼り付けを実行するマクロ
Sub MyCopyPaste(oRange_Input As Range, oRange_Output As Range)
    Dim i As Integer

    'コピー
    oRange_Input.Copy

    '値と書式を貼り付け
    oRange_Output.PasteSpecial xlValues
    oRange_Output.PasteSpecial xlFormats

    '行の高さのコピー
    For i = 1 To oRange_Input.Rows.Count
        oRange_Output.Cells(i, 1).RowHeight _
            = oRange_Input.Rows(i).RowHeight
    Next
End Sub