ExcelVBAでグループごとの縦→横変換をする(ExcelVBA)

Excelでグループごとに縦横変換したい、ということがあったのでメモ。

グループごとの縦横変換とは

下図↓のようなグループを、

このように↓したいということです。グループごとの項目数は可変になる場合も考慮して、縦横変換したいと思いました。

すでに答えはあった

同じようなことをしたい人はすでにいたようで、まさにコレ！というものを見つけました。まさにベストアンサー。

少しアレンジ

上記の例では同一シート内に変換結果を出力していましたので、別シートに出力するようにしました。
A列、B列に値を置いておけばOKなはず。

Option Explicit

Sub グループ縦横変換()
    Const SHEET_NAME As String = "converted"
    
    Dim beginRowNum As Long
    Dim maxRowNum As Long
    Dim tmpRange As Range

    Application.ScreenUpdating = False

    ' A列最上行の行番号を取得
    beginRowNum = A列の最上行の行番号を取得する()

    ' B列最下行の行番号を取得
    maxRowNum = B列最下行の行番号を取得する()

    ' 結果用シートを同ブック末尾に追加
    ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
    Worksheets(Worksheets.Count).Name = SHEET_NAME
    
    ' グループごとの縦横変換
    For Each tmpRange In Worksheets(1).Range("B" & beginRowNum & ":B" & maxRowNum)
        ' A列に値があったら行頭としてコピー
        If tmpRange.Offset(, -1).Value <> "" Then
           tmpRange.Offset(, -1).Copy Worksheets(SHEET_NAME).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        End If
        
        ' B列を縦横変換
        tmpRange.Copy Worksheets(SHEET_NAME).Cells(Cells(Rows.Count, 1).End(xlUp).Row, Columns.Count).End(xlToLeft).Offset(, 1)
    Next
    
    Application.ScreenUpdating = True
End Sub

Function A列の最上行の行番号を取得する()
    Dim tmpRange As Range
    Dim beginRowNum As Long
    
    Set tmpRange = ActiveSheet.Cells(1, 1)
    beginRowNum = tmpRange.End(xlDown).Row
    Set tmpRange = Nothing

    A列の最上行の行番号を取得する = beginRowNum
End Function

Function B列最下行の行番号を取得する()
    Dim tmpRange As Range
    Dim maxRowNum As Long
    
    Set tmpRange = ActiveSheet.Cells(Rows.Count, 2)
    maxRowNum = tmpRange.End(xlUp).Row
    Set tmpRange = Nothing

    B列最下行の行番号を取得する = maxRowNum
End Function