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

(０)目次＆概説

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

(１) マクロ概要

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

＞目次にもどる

(２) 使用方法

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

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

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

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

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

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

＞目次にもどる

(３) アルゴリズム概要

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

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

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

＞目次にもどる

(４) プログラム

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

＞目次にもどる