pgbigorokuのブログ

プログラムの再利用できそうなコードをアップ

EXCEL VBA Rangeオブジェクトのアクセスを簡単にする。<clsRange>

Addressで返すオブジェクト（Selectなどなど）が、A1などの形式で、R1C1形式で取得するの難しくありませんか？
特に複数範囲選択されていると、目が回ります。
そんなときに、このclsRangeを利用すると、Address値を入れるだけで、R1C1形式での取得や、選択範囲全体の列番号を取得できます。

イメージ

clsRange


サンプル

    Dim cRange  As New clsRange
    cRange.Address = "B2:C2,D4:D5"
    
    Debug.Print cRange.Address
    Debug.Print cRange.SubAddress_count
    Debug.Print cRange.FirstRow
    Debug.Print cRange.LastRow
    Debug.Print cRange.Right
    Debug.Print cRange.Left
    Debug.Print cRange.SubAddress_address(1)
    Debug.Print cRange.SubAddress_address(2)
    Debug.Print cRange.SubAddress_address_FirstRow(1)
    Debug.Print cRange.SubAddress_address_LastRow(1)
    Debug.Print cRange.SubAddress_address_Left(1)
    Debug.Print cRange.SubAddress_address_Right(1)
    cRange.Debug用_新しいシートでSubAddress指定状況を表示する

EXCEL VBA クラスモジュールの利用方法 - pgbigorokuのブログ

クラス１つめ

'オブジェクト名は「clsRangeOneItem」にしてください。
'  クラス「clsRange」を利用するために必要なクラスです。
'
'
'機能　選択セル１つの、「行番号」・「列番号」および「SubRange番号」の値を保持する。
'
'URL https://pgbigoroku.hatenablog.com/entry/2022/08/25/232622
'２０２２／８／２３
Option Explicit


Public lng行番号 As Long
Public int列番号 As Integer
Public intSubAddress番号 As Integer

'
'機能　このセルで指定した位置「行番号、列番号、SubRange番号」と
'　　　このセルで指定する位置「行番号、列番号、SubRange番号」
'　　が一致するか？
'
'引数
'ByVal plng行番号 As Long　　　　　この行番号と一致するか？（-1の場合すべての数を受け入れ）
'ByVal pint列番号 As Integer　　　この列番号と一致するか？（-1の場合すべての数を受け入れ）
'ByVal pintSubRange番号 As Integer　このSubRange番号と一致するか？（-1の場合すべての数を受け入れ）
'
'戻り値
'　　TRUE　　　　一致する
'　　FALSE　　　　一致しない
'

Public Function is自信の位置情報と一致するか(ByVal plng行番号 As Long, _
                                            ByVal pint列番号 As Integer, _
                                            ByVal pintSubRange番号 As Integer) As Boolean
    If plng行番号 = -1 Then
        'OK
        is自信の位置情報と一致するか = is自信の位置情報と一致するか_Sub(pint列番号, pintSubRange番号)
    ElseIf plng行番号 = lng行番号 Then
        'OK
        is自信の位置情報と一致するか = is自信の位置情報と一致するか_Sub(pint列番号, pintSubRange番号)
    Else
        is自信の位置情報と一致するか = False
    End If
End Function

'　上の関数「is自信の位置情報と一致するか」のサブルーチン
Private Function is自信の位置情報と一致するか_Sub(ByVal pint列番号 As Integer, _
                                                    ByVal pintSubRange番号 As Integer) As Boolean
    If pint列番号 = -1 Then
        'OK
        is自信の位置情報と一致するか_Sub = is自信の位置情報と一致するか_Sub_Sub(pintSubRange番号)
    ElseIf pint列番号 = int列番号 Then
        'OK
        is自信の位置情報と一致するか_Sub = is自信の位置情報と一致するか_Sub_Sub(pintSubRange番号)
    Else
        is自信の位置情報と一致するか_Sub = False
    End If
End Function

'　上の関数「is自信の位置情報と一致するか_Sub」のサブルーチン
Private Function is自信の位置情報と一致するか_Sub_Sub(ByVal pintSubRange番号 As Integer) As Boolean
    If pintSubRange番号 = -1 Then
        'OK
        is自信の位置情報と一致するか_Sub_Sub = True
    ElseIf pintSubRange番号 = intSubAddress番号 Then
        'OK
        is自信の位置情報と一致するか_Sub_Sub = True
    Else
        is自信の位置情報と一致するか_Sub_Sub = False
    End If
End Function

クラス２つめ

'オブジェクト名は「clsRange」にしてください。
'
'   クラス機能　　　:  Rangeオブジェクトのアクセスを簡単にするクラス
'
'
'URL https://pgbigoroku.hatenablog.com/entry/2022/08/25/232622
'２０２２／８／２３

Option Explicit

Public mcll1つの選択セル As New Collection
Public mcllSubAddress As New Collection

Private Const pclng行最大値 As Long = 1048576




'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'　　Addressプロパティ
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
Property Let Address(pstrAddress As String)
    Dim cRangeOneItem As clsRangeOneItem
    Dim varFor As Variant
    Call nisubCollectionClear(mcll1つの選択セル)
    Call nisubCollectionClear(mcllSubAddress)
    For Each varFor In Range(pstrAddress)
        Set cRangeOneItem = New clsRangeOneItem
        cRangeOneItem.int列番号 = varFor.Column
        cRangeOneItem.lng行番号 = varFor.Row
        cRangeOneItem.intSubAddress番号 = 0
        mcll1つの選択セル.Add cRangeOneItem
    Next
    Call psubSubAddressを計算し代入するメイン
End Property

Property Get Address() As String
    Address = nistrコレクションが文字列の場合結合する(mcllSubAddress, ",")
End Property


'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'　　SubAddress取得関連
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/


'
'　SubAddressの数を取得
'
Property Get SubAddress_count() As Integer
    SubAddress_count = mcllSubAddress.Count
End Property

'
'　SubAddressの値を取得
'
Property Get SubAddress_address(ByVal pintNo As Integer) As String
    SubAddress_address = mcllSubAddress(pintNo)
End Property

Public Function SubAddress_address_FirstRow(ByVal pintNo As Integer) As Long
    Dim cRange As New clsRange
    cRange.Address = Me.SubAddress_address(pintNo)
    SubAddress_address_FirstRow = cRange.FirstRow
End Function

Public Function SubAddress_address_LastRow(ByVal pintNo As Integer) As Long
    Dim cRange As New clsRange
    cRange.Address = Me.SubAddress_address(pintNo)
    SubAddress_address_LastRow = cRange.LastRow
End Function

Public Function SubAddress_address_Right(ByVal pintNo As Integer) As Integer
    Dim cRange As New clsRange
    cRange.Address = Me.SubAddress_address(pintNo)
    SubAddress_address_Right = cRange.Right
End Function

Public Function SubAddress_address_Left(ByVal pintNo As Integer) As Integer
    Dim cRange As New clsRange
    cRange.Address = Me.SubAddress_address(pintNo)
    SubAddress_address_Left = cRange.Left
End Function

'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'　　デバッグ用特殊関数関連
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
Public Sub Debug用_新しいシートでSubAddress指定状況を表示する()
    Dim wkb出力先 As Workbook
    Set wkb出力先 = Workbooks.Add
    
    Dim intFor1つのSubAddress As Integer
    For intFor1つのSubAddress = 1 To mcllSubAddress.Count
        Dim cRange As New clsRange
        cRange.Address = mcllSubAddress(intFor1つのSubAddress)
        Call 指定シートの指定範囲に同じ値を入力する(cRange, wkb出力先.Worksheets(1), intFor1つのSubAddress)
    Next
End Sub

'　指定シートの指定範囲に同じ値を入力します。
'
'引数
'ByRef pcRange情報 As clsRange　　　　挿入するRangeAddressが入ったclsRangeクラス
'ByVal pwks挿入先シート As Worksheet　挿入先のWorksheet
'ByVal pstr挿入する値 As String　　　挿入するデータ
Private Sub 指定シートの指定範囲に同じ値を入力する(ByRef pcRange情報 As clsRange, _
                                                    ByVal pwks挿入先シート As Worksheet, _
                                                    ByVal pstr挿入する値 As String)
    Dim rng対象 As Range
    Dim varForセル As Variant
    Set rng対象 = pwks挿入先シート.Range(pcRange情報.Address)
    For Each varForセル In rng対象
        varForセル.Value = pstr挿入する値
    Next
End Sub


'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/
'   SubAddressを計算し代入する。
'_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/_/

'
'   SubAddressを計算し代入するメイン
'
Private Sub psubSubAddressを計算し代入するメイン()
    Dim intSubAddressCount As Integer
    Dim strTemp As String
    intSubAddressCount = 1
    strTemp = "-"
    Do Until strTemp = ""
        strTemp = pstrSerchSqure(intSubAddressCount)
        If strTemp = "" Then Exit Do
        mcllSubAddress.Add strTemp
        intSubAddressCount = intSubAddressCount + 1
    Loop
End Sub


Private Function pstrSerchSqure(ByVal pintSubAddressCount As Integer) As String
    Dim lng1FirstRow As Long
    Dim int2FirstCol As Integer
    Dim lng3LastRow As Long
    Dim int4LastCol As Integer
    
    '1.
    lng1FirstRow = pintSubAddressを振っていない一番初めの行を探す()
    If lng1FirstRow = 0 Then
        pstrSerchSqure = ""
        Exit Function
    End If
    '2
    int2FirstCol = pint指定行の最初にSqureフラグがない列を戻す(lng1FirstRow)
    '3
    lng3LastRow = plng何行目までデータが続くか(lng1FirstRow, int2FirstCol)
    '4
    int4LastCol = pint何列目までデータが続くか(lng1FirstRow, lng3LastRow, int2FirstCol)
    
    Call pbln指定したSubbAddressの1つの選択せるのSubAddressを設定する(lng1FirstRow, int2FirstCol, lng3LastRow, int4LastCol, pintSubAddressCount)
    pstrSerchSqure = nistrA1形式FromR1C1形式(lng1FirstRow, int2FirstCol, lng3LastRow, int4LastCol)
End Function


'_____________________(1)________________________________________________
'　選択セル全体の一番初めの行
'
'戻り値
'　　　1以上　　　一番初めの行
'　　　0　　　　すべてSubAddress番号がふられているとき
Private Function pintSubAddressを振っていない一番初めの行を探す() As Long
    Dim lngRet As Long
    Dim oneitem As clsRangeOneItem
    lngRet = pclng行最大値
    For Each oneitem In mcll1つの選択セル
        If oneitem.lng行番号 < lngRet Then
            If oneitem.intSubAddress番号 = 0 Then
                lngRet = oneitem.lng行番号
            End If
        End If
    Next
    If lngRet = pclng行最大値 Then
        pintSubAddressを振っていない一番初めの行を探す = 0
    Else
        pintSubAddressを振っていない一番初めの行を探す = lngRet
    End If
End Function


Private Sub pbln指定したSubbAddressの1つの選択せるのSubAddressを設定する _
            (ByVal plngFirstRow As Long, _
             ByVal pintFirstCol As Integer, _
             ByVal plngLastRow As Long, _
             ByVal pintLastCol As Integer, _
             ByVal pintSubAddressCount As Integer)
    Dim lngForRow As Long
    Dim intForCol As Integer
    For lngForRow = plngFirstRow To plngLastRow
        For intForCol = pintFirstCol To pintLastCol
            Call pbln指定したSubbAddressの1つの選択せるのSubAddressを設定するSub(lngForRow, intForCol, pintSubAddressCount)
        Next
    Next
End Sub

Private Sub pbln指定したSubbAddressの1つの選択せるのSubAddressを設定するSub(ByVal plngFirstRow As Long, ByVal pintFirstCol As Integer, ByVal pintSubAddressCount As Integer)
    Dim oneitem As clsRangeOneItem
    For Each oneitem In mcll1つの選択セル
        If oneitem.is自信の位置情報と一致するか(plngFirstRow, pintFirstCol, 0) Then
            oneitem.intSubAddress番号 = pintSubAddressCount
        End If
    Next
End Sub


'_____________________(2)________________________________________________
Private Function pint指定行の最初にSqureフラグがない列を戻す(ByVal plngRow As Long) As Integer
    Dim intRet As Integer
    Dim oneitem As clsRangeOneItem
    For Each oneitem In mcll1つの選択セル
        If oneitem.lng行番号 = plngRow Then
            If oneitem.intSubAddress番号 = 0 Then
                If intRet = 0 Then
                    intRet = oneitem.int列番号
                Else
                    If intRet > oneitem.int列番号 Then
                        intRet = oneitem.int列番号
                        
                    End If
                End If
            End If
        End If
    Next
    pint指定行の最初にSqureフラグがない列を戻す = intRet
End Function


'_____________________(3)________________________________________________

Private Function plng何行目までデータが続くか(ByVal plngRow As Long, ByVal pintCol As Integer) As Long
    Dim lngForRow As Long
    lngForRow = plngRow + 1
    Do While pblnExsit(lngForRow, pintCol, 0) = True
        lngForRow = lngForRow + 1
    Loop
    plng何行目までデータが続くか = lngForRow - 1
End Function

'_____________________(4)________________________________________________
Private Function pint何列目までデータが続くか(ByVal lngRowStart As Long, ByVal lngRowEnd As Long, ByVal intCol As Integer) As Long
    Dim intForCol As Integer
    intForCol = intCol + 1
    Do While pint何列目までデータが続くかSub(lngRowStart, lngRowEnd, intForCol) = True
        intForCol = intForCol + 1
    Loop
    pint何列目までデータが続くか = intForCol - 1
End Function


Private Function pint何列目までデータが続くかSub(ByVal lngRowStart As Long, ByVal lngRowEnd As Long, ByVal intCol As Integer) As Boolean
    Dim lngRow As Long
    For lngRow = lngRowStart To lngRowEnd
        If pblnExsit(lngRow, intCol, 0) = True Then
        Else
            pint何列目までデータが続くかSub = False
            Exit Function
        End If
    Next
    pint何列目までデータが続くかSub = True
End Function


'----------------

Private Function pblnExsit(ByVal plngRow As Long, ByVal pintCol As Integer, ByVal intSquareNo As Integer) As Boolean
    Dim oneitem As clsRangeOneItem
    For Each oneitem In mcll1つの選択セル
        If oneitem.is自信の位置情報と一致するか(plngRow, pintCol, intSquareNo) = True Then
            pblnExsit = True
            Exit Function
        End If
    Next
    pblnExsit = False
End Function


'　選択セル全体の一番初めの行
Public Function FirstRow(Optional ByVal plngStart As Long = 0) As Long
    Dim lngRet As Long
    Dim oneitem As clsRangeOneItem
    If plngStart = 0 Then
        plngStart = 0
    End If
    If mcll1つの選択セル.Count = 0 Then
        FirstRow = 0
    Else
        lngRet = pclng行最大値
        For Each oneitem In mcll1つの選択セル
            If oneitem.lng行番号 < lngRet Then
                If oneitem.lng行番号 >= plngStart Then
                    lngRet = oneitem.lng行番号
                    
                End If
            End If
        Next
        FirstRow = lngRet
    End If
End Function

Public Function LastRow(Optional ByVal plngEnd As Long = 0) As Long
    Dim lngRet As Long
    Dim oneitem As clsRangeOneItem
    If plngEnd = 0 Then
        plngEnd = pclng行最大値
    End If
    If mcll1つの選択セル.Count = 0 Then
        LastRow = 0
    Else
        lngRet = 0
        For Each oneitem In mcll1つの選択セル
            If oneitem.lng行番号 > lngRet Then
                If oneitem.lng行番号 <= plngEnd Then
                    lngRet = oneitem.lng行番号
                End If
            End If
        Next
        LastRow = lngRet
    End If
End Function

Public Function Left(Optional ByVal pintStart As Long = 0) As Integer
    Dim lngRet As Integer
    Dim oneitem As clsRangeOneItem
    If pintStart = 0 Then
        pintStart = 0
    End If
    If mcll1つの選択セル.Count = 0 Then
        Left = 0
    Else
        lngRet = 16384
        For Each oneitem In mcll1つの選択セル
            If oneitem.int列番号 < lngRet Then
                If oneitem.int列番号 >= pintStart Then
                    lngRet = oneitem.int列番号
                End If
            End If
        Next
        Left = lngRet
    End If
End Function

'
Public Function Right(Optional ByVal pintEnd As Integer = 0) As Integer
    Dim intRet As Integer
    Dim oneitem As clsRangeOneItem
    If pintEnd = 0 Then
        pintEnd = 16384
    End If
    
    If mcll1つの選択セル.Count = 0 Then
        Right = 0
    Else
        intRet = 0
        For Each oneitem In mcll1つの選択セル
            If oneitem.int列番号 > intRet Then
                If oneitem.int列番号 <= pintEnd Then
                    intRet = oneitem.int列番号
                End If
            End If
        Next
        Right = intRet
    End If
End Function

' ------------------ 共通関数(https://pgbigoroku.hatenablog.com掲載分)--------------------
'
'  セルの場所指定をA1の文字列形式で取得する。
'https://pgbigoroku.hatenablog.com/entry/2022/08/25/001634
'2021/8/23
Private Function nistrA1形式FromR1C1形式(ByVal plngFirstRow As Long, _
                                    ByVal pintFirstCol As Integer, _
                                    ByVal plngLastRow As Long, _
                                    ByVal pintLastCol As Integer) As String
    nistrA1形式FromR1C1形式 = Range(Cells(plngFirstRow, pintFirstCol), Cells(plngLastRow, pintLastCol)).Address
End Function

'
'　コレクションが文字列の場合結合する。
'https://pgbigoroku.hatenablog.com/entry/2022/08/25/094908
'2021/8/21
Private Function nistrコレクションが文字列の場合結合する(ByRef pcll As Collection, ByVal pstrDivide As String) As String
    Dim strRet As String
    Dim varFor As Variant
    On Error GoTo Errnisubコレクションが文字列の場合結合する
        For Each varFor In pcll
            strRet = strRet & pstrDivide & varFor
        Next
        nistrコレクションが文字列の場合結合する = Mid(strRet, Len(pstrDivide) + 1)
    
    Exit Function
Errnisubコレクションが文字列の場合結合する:
    nistrコレクションが文字列の場合結合する = ""
    Exit Function
    Resume Next
End Function

'
'　コレクションのすべてのアイテムを削除する。
'
'https://pgbigoroku.hatenablog.com/entry/2022/08/25/094125
'2021/8/21
Private Sub nisubCollectionClear(ByRef pcll As Collection)
    Do Until pcll.Count = 0
        pcll.Remove (1)
    Loop
End Sub