【Excel】縦の表定義から横の表定義に変換

現場では表定義は縦形式が多いですが、
エビデンスや他作業時は横形式の方が良い場合もあるので、マクロで変換します。

Sub TblDefConversion()
'
' TblDefConversion Macro
'
' テーブル定義を縦から横に変換する。
    
    ' 変換後のエクセル用変数を宣言する。
    Dim newBook As String
    Dim NewWorkSheet As Worksheet

    ' 変換後のエクセルを追加する。
    Workbooks.Add
    newBook = ActiveWorkbook.Name

    ' 変換前のエクセル用変数を宣言する。
    Dim oldWorkBook As Workbook
    Set oldWorkBook = Workbooks("Book1.xlsx")
    Dim oldWorkSheet As Worksheet
    Dim tblNameRowPoint As Long   ' テーブル名が存在する行数
    Dim tblNameCellPoint As Long  ' テーブル名が存在する列数
    tblNameRowPoint = 4
    tblNameCellPoint = 21
    Dim colNameLogicalRowPoint As Long   ' 項目名(論理名)が存在する行数
    Dim colNameLogicalCellPoint As Long  ' 項目名(論理名)が存在する列数
    Dim colNamePhysicalRowPoint As Long  ' 項目名(物理名)が存在する行数
    Dim colNamePhysicalCellPoint As Long ' 項目名(物理名)が存在する列数
    Dim colTypeRowPoint As Long          ' 型が存在する行数
    Dim colTypeCellPoint As Long         ' 型が存在する列数
    Dim colSizeRowPoint As Long          ' サイズが存在する行数
    Dim colSizeCellPoint As Long         ' サイズが存在する列数
    colNameLogicalRowPoint = 9
    colNameLogicalCellPoint = 2
    colNamePhysicalRowPoint = colNameLogicalRowPoint
    colNamePhysicalCellPoint = 13
    colTypeRowPoint = colNameLogicalRowPoint
    colTypeCellPoint = 24
    colSizeRowPoint = colNameLogicalRowPoint
    colSizeCellPoint = 28

    ' 変換前のエクセルシート分繰り返す。
    For Each oldWorkSheet In oldWorkBook.Worksheets

        ' 変換後のエクセルシートとA1セルに変換前のエクセルシート名を設定する。
        ' エクセルでは関数に()をつけると戻り値を伴う。
        Workbooks(newBook).Activate
        Set NewWorkSheet = Worksheets.Add()
        MsgBox oldWorkSheet.Cells(tblNameRowPoint, tblNameCellPoint).Value
        NewWorkSheet.Name = oldWorkSheet.Cells(tblNameRowPoint, tblNameCellPoint).Value
        Cells(1, 1).Value = oldWorkSheet.Cells(tblNameRowPoint, tblNameCellPoint).Value
        
        ' 変換前エクセルの項目名の最初と最後を設定する。
        oldWorkBook.Activate
        oldWorkSheet.Activate
        Dim i As Long
        Dim MaxRow As Long
        MaxRow = oldWorkSheet.Cells(Rows.Count, colNameLogicalCellPoint).End(xlUp).Row
        
        ' 変換前エクセルの項目名の最初から最後までを繰り返す。
        For i = colNameLogicalRowPoint To MaxRow

            ' 項目名(論理名)、項目名(物理名)、型、サイズを取得する。
            Dim colNameLogical As String
            Dim colNamePhysical As String
            Dim colType As String
            Dim colSize As String
            colNameLogical = Cells(i, colNameLogicalCellPoint).Value
            colNamePhysical = Cells(i, colNamePhysicalCellPoint).Value
            colType = Cells(i, colTypeCellPoint).Value
            colSize = Cells(i, colSizeCellPoint).Value

            ' 変換後のエクセルに各々の値を取得する。
            Workbooks(newBook).Activate
            NewWorkSheet.Cells(2, i - colNameLogicalRowPoint + 1).Value = colNameLogical
            NewWorkSheet.Cells(3, i - colNamePhysicalRowPoint + 1).Value = colNamePhysical
            NewWorkSheet.Cells(4, i - colTypeRowPoint + 1).Value = colType
            NewWorkSheet.Cells(5, i - colSizeRowPoint + 1).Value = colSize

            ' 変換前のエクセルをアクティブにしておく。
            oldWorkBook.Activate

        Next i
    Next oldWorkSheet

End Sub