VBAによるマトリクスの行列を反転させて転記するプログラム

(０)目次＆概説

(１) マクロ概要
 (２) 使用方法
 (３) アルゴリズム概要
 (４) プログラム

(１) マクロ概要

マトリクス形式で表現されたデータの行と列を入れ替えるプログラムです。
(※Excelであれば、コピーして貼り付けする際に「形式を選択して貼り付け(S)」を選択して、その中で「行/列の入れ替え(T)」を選択すると同様の操作ができます。Excelで標準装備している操作ですが、今回はVBAの勉強も兼ねて自力でプログラムを作成してみました・・)。

＞目次にもどる

(２) 使用方法

使用に際しては以下の準備作業を行います。
①シート「2.OldMatrix」(*注1)に転記前のマトリクスを準備します（*注1：シート名は任意の名前を指定可能）

②シート「2.NewMatrix」(*注2)に転記後のマトリクスの中の値が空の雛形を準備します（*注2：シート名は任意の名前を指定可能）
※時間が取れる時に、転記後は雛形を用意せずとも、ラベル含めて反転＆転記してくれるように改修いたします。

③シート「Controller」にて以下のようにマクロ動作のインプット情報を与える表を作成します。この際、マトリクスの開始行／終了行／開始列／終了列の情報は各自のマトリクスに応じて変更します。

開始行や終了行などは、縦ラベルと横ラベルの交点の値が開始・終了する行の事を指しており、以下のようなイメージとなります。

④シート「Controller」にて、VBAプログラム「TurnOverMatrixRowCol()」呼び出し用のボタンを設置します。

準備は以上で、後はボタンを押せば「2.OldMatrix」シートの情報を、行と列を逆にして「2.NewMatrix」シートに転記します。

＞目次にもどる

(３) アルゴリズム概要

前半部（転記元のマトリクスの情報を取得）の変数の定義は以下の通りです。

No	変数名	型	説明
1	SheetName	String	転記元のマトリクスのあるシート名を保持する変数。
2	RowStart	Integer	転記元のマトリクスの行開始位置を保持する変数。
3	RowEnd	Integer	転記元のマトリクスの行終了位置を保持する変数。
4	ColStart	Integer	転記元のマトリクスの列開始位置を保持する変数。
5	ColEnd	Integer	転記元のマトリクスの列終了位置を保持する変数。
6	MatrixSize	Integer	マトリクスの要素数（行ラベル×列ラベル）を保持する変数。
7	RowBand	Variant	行ラベルを保持する配列。
8	ColBand	Variant	列ラベルを保持する配列。
9	Value	Variant	マトリクスの要素を保持する配列。

後半部（取得した情報を転記先のマトリクスに反映）の変数の定義は以下の通りです。

No	変数名	型	説明
1	SheetName2	String	転記先のマトリクスのあるシート名を保持する変数。
2	RowStart2	Integer	転記先のマトリクスの行開始位置を保持する変数。
3	RowEnd2	Integer	転記先のマトリクスの行終了位置を保持する変数。
4	ColStart2	Integer	転記先のマトリクスの列開始位置を保持する変数。
5	ColEnd2	Integer	転記先のマトリクスの列終了位置を保持する変数。

処理のフローは以下の通りです。

Lv.	(処理概要) 転記元のマトリクスの情報（行ラベル、列ラベル、値）を取得する。
1	転記元で、行の最初～最後までループ　（ループ変数＝i）
2	∟転記元で、列の最初～最後までループ　（ループ変数＝j）
3	∟カウンター（Count）をインクリメント
3	∟座標(i, j)の位置の列ラベルを取得
3	∟座標(i, j)の位置の行ラベルを取得
3	∟座標(i, j)の値を取得
Lv.	(処理概要) 取得した転記元マトリクス情報を、転記先のマトリクスの適切な位置に転記する。
1	転記先で、行の最初～最後までループ　（ループ変数＝k）
2	∟転記先で、列の最初～最後までループ　（ループ変数＝m）
3	∟転記先で、転記元の取得情報の最初～最後までループ　（ループ変数＝n）
4	∟転記先の各座標に対して転記元の全パターンと突合を行い一致を判定　　　　（※転記先と転記元で「行ラベル」＆「列ラベル」が両方一致したら情報一致と判定）
4	∟情報一致したら、転記元の値を転記先のセルにコピー

＞目次にもどる

(４) プログラム

Sub TurnOverMatrixRowCol()

    'コピー元シートから情報取得
    Dim SheetName   As String:  SheetName = Worksheets("2.Controller").Cells(2, 3).Value  '転記元シート
    Dim RowStart    As Integer: RowStart = Worksheets("2.Controller").Cells(3, 3).Value
    Dim RowEnd      As Integer: RowEnd = Worksheets("2.Controller").Cells(4, 3).Value
    Dim ColStart    As Integer: ColStart = Worksheets("2.Controller").Cells(5, 3).Value
    Dim ColEnd      As Integer: ColEnd = Worksheets("2.Controller").Cells(6, 3).Value
    Dim MatrixSize  As Integer: MatrixSize = (RowEnd - RowStart + 1) * (ColEnd - ColStart + 1)
    Dim RowBand     As Variant: ReDim RowBand(MatrixSize)
    Dim ColBand     As Variant: ReDim ColBand(MatrixSize)
    Dim Value       As Variant: ReDim Value(MatrixSize)
    
    Worksheets("2.NewMatrix").Activate
    
    '行のループ
    For i = RowStart To RowEnd
        '列のループ
        For j = ColStart To ColEnd
            
            Count = Count + 1
            
            '列の帯にある値を取得
            ColBand(Count) = Worksheets(SheetName).Cells(RowStart - 1, j).Value
            
            '行の帯にある値を取得
            RowBand(Count) = Worksheets(SheetName).Cells(i, ColStart - 1).Value
            
            '行列の交点にある値を取得
            Value(Count) = Worksheets(SheetName).Cells(i, j)
        Next j
    Next i
    
    'コピー先のシートに転記
    Dim SheetName2  As String:  SheetName2 = Worksheets("2.Controller").Cells(2, 4).Value  '転記先シート
    Dim RowStart2   As Integer: RowStart2 = Worksheets("2.Controller").Cells(3, 4).Value
    Dim RowEnd2     As Integer: RowEnd2 = Worksheets("2.Controller").Cells(4, 4).Value
    Dim ColStart2   As Integer: ColStart2 = Worksheets("2.Controller").Cells(5, 4).Value
    Dim ColEnd2     As Integer: ColEnd2 = Worksheets("2.Controller").Cells(6, 4).Value
    
    '行のループ
    For k = RowStart2 To RowEnd2
        '列のループ
        For m = ColStart2 To ColEnd2
            
            '取得した全項目について、新マトリクスの行列のどこに当てはまるかをチェック
            For n = 1 To Count
                                    
                '項目に対して以下のチェックを行い、TRUEなら正しい転記先とみなす。
                '　①転記先シートの「新」列帯（元行帯）と名前が一致するか？
                '　かつ（AND）
                '　②転記先シートの「新」行帯（元列帯）と名前が一致するか？
                If Worksheets(SheetName2).Cells(RowStart2 - 1, m).Value = RowBand(n) _
                And Worksheets(SheetName2).Cells(k, ColStart2 - 1).Value = ColBand(n) Then

                    '一致した場合は値の正しい転記先であると判断して、転記を行う
                    Worksheets(SheetName2).Cells(k, m).Value = Value(n)
                
                End If
            Next n
        Next m
    Next k
    
End Sub

＞目次にもどる