VBA Generic code

行・列の項目を取得する

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

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

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

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


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


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

Sub Get_RC_Item() '表と名列が同じシート上にあるケース

    Dim lngR As Long, lngC As Long
    Dim lngRowsC_A As Long, lngRowsC_B As Long
    Dim lngIndexA As Long, lngIndexB As Long
    Dim varA As Variant, varB As Variant
    Dim varAreaA() As Variant, 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" '名列のセル範囲 ※名前が左端で3列を選択
    '-----------------------------------------
    Dim lngR As Long, lngC As Long
    Dim lngRowsC_A As Long, lngRowsC_B As Long
    Dim lngIndexA As Long, lngIndexB As Long
    Dim varA As Variant, varB As Variant
    Dim varAreaA() As Variant, 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

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

ページトップへ戻る
Copyright(C) 2009- 坂江 保 All Rights Reserved.