行・列の項目を取得する

行・列の項目を取得する2010.07.04

遠足の班表や林間学校の部屋割り表の、行・列それぞれの項目を取得し、名列表に設定したい。ワークシート関数でやれないこともありませんが、VBAの方が手軽に出来ます。

[例]　下図、①の表の行・列項目（班・係）を取得し、②の名列の該当する場所に設定します。

【お薦め】マクロ・プロシージャを管理する無料のツール！
　Excelマクロ管理ツール

サンプルコード表と名列が同じシート上にあるケース

●事前準備
1．表を選択。（行・列項目を含む範囲を選択。下図赤範囲）
2．「Ctrl」を押しながら、名列を選択。（名前が左端になるように、３列を選択。下図橙範囲）
3．マクロ[Get_RC_Item]を実行。

成功すると次のようになります。

●留意点
・名列範囲の２列目に「行項目」、３列目に「列項目」が設定されます
・セルを選択しないとマクロは実行しません
・選択セルが単一だとマクロは実行しません
・表と名列の２か所を正確に選択する必要があります
・マクロ実行後は「元に戻す」は使えません

コードの貼り付け場所　　　 VBAコードをカラーで印刷・Web掲載するためのツールはこちら

Sub Get_RC_Item() '表と名列が同じシート上にあるケース
    Dim lngR       As Long
    Dim lngC       As Long
    Dim lngRowsC_A As Long
    Dim lngRowsC_B As Long
    Dim lngIndexA  As Long
    Dim lngIndexB  As Long
    Dim varA       As Variant
    Dim varB       As Variant
    Dim varAreaA() As Variant
    Dim varAreaB() As Variant
    With Application
        If TypeName(.Selection) <> "Range" Then Exit Sub
        If .Selection.Areas.Count = 1 Then Exit Sub
        For lngRowsC_A = 1 To 2
            If .Selection.Areas(lngRowsC_A).Cells.Count = 1 Then Exit Sub
        Next
        varAreaA = .Selection.Areas(1).Value
        lngRowsC_A = .Selection.Areas(1).Rows.Count
        varAreaB = .Selection.Areas(2).Value
        lngRowsC_B = .Selection.Areas(2).Rows.Count
        For Each varB In varAreaB
            lngIndexA = 0
            lngIndexB = lngIndexB + 1
            If varB <> Empty Then
                For Each varA In varAreaA
                    lngIndexA = lngIndexA + 1
                    If varB = varA Then
                        lngR = ((lngIndexA - 1) Mod lngRowsC_A) + 1
                        lngC = (lngIndexA + lngRowsC_A - 1) \ lngRowsC_A
                        varAreaB(lngIndexB, 2) = varAreaA(lngR, 1)
                        varAreaB(lngIndexB, 3) = varAreaA(1, lngC)
                        Exit For
                    End If
                Next
            End If
            If lngIndexB = lngRowsC_B Then Exit For
        Next
        .ScreenUpdating = False
        .Selection.Areas(2).Value = varAreaB
        .ScreenUpdating = True
    End With
End Sub

サンプルコード表と名列が異なるシートにあるケース

この場合は、セルを選択する必要はありませんが、下記コードの赤部にシート名、セル範囲を正確に入力し、マクロを実行します。

Sub Get_RC_Item_2() '表と名列が異なるシートにあるケースです。
    Const conSheetA As String = "Sheet1" '表のあるシート名
    Const conRangeA As String = "B2:F6" '表のセル範囲
    Const conSheetB As String = "Sheet2" '名列のあるシート名
    Const conRangeB As String = "C9:E22" '名列のセル範囲　※名前が左端で３列を選択
    '-----------------------------------------
    Dim lngR       As Long
    Dim lngC       As Long
    Dim lngRowsC_A As Long
    Dim lngRowsC_B As Long
    Dim lngIndexA  As Long
    Dim lngIndexB  As Long
    Dim varA       As Variant
    Dim varB       As Variant
    Dim varAreaA() As Variant
    Dim varAreaB() As Variant
    With Application
        With .Worksheets(conSheetA).Range(conRangeA)
            varAreaA = .Value
            lngRowsC_A = .Rows.Count
        End With
        With .Worksheets(conSheetB).Range(conRangeB)
            varAreaB = .Value
            lngRowsC_B = .Rows.Count
        End With
        For Each varB In varAreaB
            lngIndexA = 0
            lngIndexB = lngIndexB + 1
            If varB <> Empty Then
                For Each varA In varAreaA
                    lngIndexA = lngIndexA + 1
                    If varB = varA Then
                        lngR = ((lngIndexA - 1) Mod lngRowsC_A) + 1
                        lngC = (lngIndexA + lngRowsC_A - 1) \ lngRowsC_A
                        varAreaB(lngIndexB, 2) = varAreaA(lngR, 1)
                        varAreaB(lngIndexB, 3) = varAreaA(1, lngC)
                        Exit For
                    End If
                Next
            End If
            If lngIndexB = lngRowsC_B Then Exit For
        Next
        .ScreenUpdating = False
        .Worksheets(conSheetB).Range(conRangeB).Value = varAreaB
        .ScreenUpdating = True
    End With
End Sub

赤字で指定したセルが単一の場合はエラーになります。

トップ　>　汎用コード　>　行・列の項目を取得する