ついでに行列変換

ここまで来たついでに、行と列の組み替えなどをやってみましょう。

前項までで、同じ矩形範囲(3行×4列)であれば何も1セルずつ転記するのではなく、矩形範囲を指定すれば1行の記述で転記できました。ですが、矩形領域の形が違ったらどうでしょう。

例えば、3行×4列⇒4行×3列だったらどうしますか？

'***************************************************************************************************
'   矩形範囲の転記サンプル                                          Module1(Module)
'
'   作成者:井上治  URL:https://www.ne.jp/asahi/excel/inoue/ [Excelでお仕事!]
'***************************************************************************************************
'変更日付 Rev  変更履歴内容------------------------------------------------------------------------>
'04/02/11(1.00)新規作成
'16/11/19(1.10)*.xlsm化
'20/01/17(1.11)記述整理等
'***************************************************************************************************
Option Explicit
'===================================================================================================
Private Const g_cnsSh1 As String = "Sheet1"
Private Const g_cnsSh2 As String = "Sheet2"

'***************************************************************************************************
'   ■■■ シート側からの呼び出し処理 ■■■
'***************************************************************************************************
'* 処理名　：TEST6_1
'* 機能　　：１セルずつ位置の変更して転記
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2004年02月11日
'* 作成者　：井上　治
'* 更新日　：2020年01月17日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：ブックを明示していないのでアクティブなブックに対して作用します
'***************************************************************************************************
Sub TEST6_1()
    '-----------------------------------------------------------------------------------------------
    Dim objSh1 As Worksheet                                         ' Sheet1
    Dim objSh2 As Worksheet                                         ' Sheet2
    Dim lngRow1 As Long                                             ' 行INDEX(Sheet1)
    Dim lngRow2 As Long                                             ' 行INDEX(Sheet2)
    Dim lngCol1 As Long                                             ' 列INDEX(Sheet1)
    Dim lngCol2 As Long                                             ' 列INDEX(Sheet2)
    Set objSh1 = Worksheets(g_cnsSh1)
    Set objSh2 = Worksheets(g_cnsSh2)
    ' 転記先行列初期値のセット
    lngRow2 = 1
    lngCol2 = 1
    ' 行のループ
    For lngRow1 = 1 To 3
        ' カラムのループ
        For lngCol1 = 1 To 4
            ' 単一セルの転記
            objSh2.Cells(lngRow2, lngCol2).Value = objSh1.Cells(lngRow1, lngCol1).Value
            ' 次の行列を判定
            lngCol2 = lngCol2 + 1
            If lngCol2 > 3 Then
                lngRow2 = lngRow2 + 1
                lngCol2 = 1
            End If
        Next lngCol1
    Next lngRow1
    ' Sheet2を表示
    objSh2.Activate
End Sub
名案が浮かばないので、1セルずつ位置の変更して転記することにしました。
処理結果は、
行列の要素数が違う場合の転記①の結果
こうなりました。

先に、転記順の配置を作り上げてしまう方法もあります。

'***************************************************************************************************
'* 処理名　：TEST6_2
'* 機能　　：配置の配列を事前に用意
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2004年02月11日
'* 作成者　：井上　治
'* 更新日　：2020年01月17日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：ブックを明示していないのでアクティブなブックに対して作用します
'***************************************************************************************************
Sub TEST6_2()
    '-----------------------------------------------------------------------------------------------
    Dim objSh1 As Worksheet                                         ' Sheet1
    Dim objSh2 As Worksheet                                         ' Sheet2
    Dim lngRow1 As Long                                             ' 行INDEX(Sheet1)
    Dim lngRow2 As Long                                             ' 行INDEX(Sheet2)
    Dim lngCol1 As Long                                             ' 列INDEX(Sheet1)
    Dim lngCol2 As Long                                             ' 列INDEX(Sheet2)
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim tblRow As Variant                                           ' 行配置テーブル
    Dim tblCol As Variant                                           ' 列配置テーブル
    Set objSh1 = Worksheets(g_cnsSh1)
    Set objSh2 = Worksheets(g_cnsSh2)
    ' 4行×3列の場合の配置の配列を作成(行と列の分)
    tblRow = Array(1, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, 4)
    tblCol = Array(1, 2, 3, 1, 2, 3, 1, 2, 3, 1, 2, 3)
    ' １セルずつ配置を変更して転記
    lngIx = 0
    ' 行のループ
    For lngRow1 = 1 To 3
        ' カラムのループ
        For lngCol1 = 1 To 4
            ' 転記先の行列を判定
            lngRow2 = tblRow(lngIx)
            lngCol2 = tblCol(lngIx)
            ' 単一セルの転記
            objSh2.Cells(lngRow2, lngCol2).Value = objSh1.Cells(lngRow1, lngCol1).Value
            ' インデックスを加算
            lngIx = lngIx + 1
        Next lngCol1
    Next lngRow1
    ' Sheet2を表示
    objSh2.Activate
End Sub
結果は上記と同じになります。

さて、では行と列の入れ替えはどうでしょう。
行列入れ替えの転記の結果
「行列入れ替え」とはこのような結果を求めることです。
直前のサンプルを利用すると、

'***************************************************************************************************
'* 処理名　：TEST6_3
'* 機能　　：行列入れ替え
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2004年02月11日
'* 作成者　：井上　治
'* 更新日　：2020年01月17日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：ブックを明示していないのでアクティブなブックに対して作用します
'***************************************************************************************************
Sub TEST6_3()
    '-----------------------------------------------------------------------------------------------
    Dim objSh1 As Worksheet                                         ' Sheet1
    Dim objSh2 As Worksheet                                         ' Sheet2
    Dim lngRow1 As Long                                             ' 行INDEX(Sheet1)
    Dim lngRow2 As Long                                             ' 行INDEX(Sheet2)
    Dim lngCol1 As Long                                             ' 列INDEX(Sheet1)
    Dim lngCol2 As Long                                             ' 列INDEX(Sheet2)
    Dim lngIx As Long                                               ' テーブルINDEX
    Dim tblRow As Variant                                           ' 行配置テーブル
    Dim tblCol As Variant                                           ' 列配置テーブル
    Set objSh1 = Worksheets(g_cnsSh1)
    Set objSh2 = Worksheets(g_cnsSh2)
    ' 4行×3列の場合の配置の配列を作成(行列入れ替え)
    tblRow = Array(1, 2, 3, 4, 1, 2, 3, 4, 1, 2, 3, 4)
    tblCol = Array(1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3, 3)
    ' １セルずつ配置を変更して転記
    lngIx = 0
    ' 行のループ
    For lngRow1 = 1 To 3
        ' カラムのループ
        For lngCol1 = 1 To 4
            ' 転記先の行列を判定
            lngRow2 = tblRow(lngIx)
            lngCol2 = tblCol(lngIx)
            ' 単一セルの転記
            objSh2.Cells(lngRow2, lngCol2).Value = objSh1.Cells(lngRow1, lngCol1).Value
            ' インデックスを加算
            lngIx = lngIx + 1
        Next lngCol1
    Next lngRow1
    ' Sheet2を表示
    objSh2.Activate
End Sub
vntArrayの変換表の順番を変更するだけで実現できます。

ですが、転記元の範囲が決まっていないような場合は上の方法では無理です。
実はセルのプロパティには行列変換の機能があります。

'***************************************************************************************************
'* 処理名　：TEST6_4
'* 機能　　：行列入れ替え②
'---------------------------------------------------------------------------------------------------
'* 返り値　：(なし)
'* 引数　　：(なし)
'---------------------------------------------------------------------------------------------------
'* 作成日　：2004年02月11日
'* 作成者　：井上　治
'* 更新日　：2020年01月17日
'* 更新者　：井上　治
'* 機能説明：
'* 注意事項：ブックを明示していないのでアクティブなブックに対して作用します
'***************************************************************************************************
Sub TEST6_4()
    '-----------------------------------------------------------------------------------------------
    Dim objSh1 As Worksheet                                         ' Sheet1
    Dim objSh2 As Worksheet                                         ' Sheet2
    Dim objRange As Range                                           ' UsedRange
    Dim cntRow As Long                                              ' 有効行数
    Dim cntCol As Long                                              ' 有効列数
    Set objSh1 = Worksheets(g_cnsSh1)
    Set objSh2 = Worksheets(g_cnsSh2)
    ' 転記元を取得
    Set objRange = objSh1.UsedRange
    ' 転記元範囲の行数､カラム数を取得
    cntRow = objRange.EntireRow.Count
    cntCol = objRange.EntireColumn.Count
    ' 転記元をコピー
    objRange.Copy
    ' 行列を変換して貼り付け(Resizeは行列を逆転する)
    objSh2.Cells(1, 1).Resize(cntCol, cntRow).PasteSpecial Paste:=xlValue, Transpose:=True
    ' コピーモード解除
    Application.CutCopyMode = False
    ' Sheet2を表示
    objSh2.Activate
End Sub
これは、「コピー」→「形式を選択して貼り付け」で「行列を入れ替える」にチェックを付けたのと同じ処理です。