GetItem

行・列の項目を取得する

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

 例では、下図「1」の表の行・列項目(班・係)を取得し、名列の該当する場所に設定します。

サンプルコード

表と名列が同じシート上にあるケース

【事前準備】
 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

選択セルが単一の場合はエラーになります。

Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.