セル範囲のアドレスから列番号のみを取得する

セル範囲のアドレスから列番号のみを取得するサブルーチンです。
返却値はモジュールレベル変数に格納しています。

Option Explicit
Option Base 1

'モジュールレベル変数
Dim lngSelectRows()

Sub getSelectRows(strAddress As String)
'------------------------------------------------------------------------------
' アドレス文字列を列番号に展開する
' getSelectRows ("$E$5:$E$8,$E$10,$E$12:$E$14")→ 配列 lngSelectRows(5,6,7,8,10,12,13,14)
'------------------------------------------------------------------------------

Const DebugFlag As Boolean = False  'デバッグ文出力フラグ
Dim i As Long
Dim strWork As String
Dim strRows As String
Dim AddressArray
Dim a As Variant
Dim lngComma As Long, s As Long, e As Long
Dim r As Long   'lngSelectRowsの添字

If DebugFlag = True Then Debug.Print "変換前"; strAddress
Erase lngSelectRows '列番号返却用配列(モジュールレベル変数)

'アドレス内の「$」と「アルファベット」を削除
strRows = ""
For i = 1 To Len(strAddress)
    strWork = Mid(strAddress, i, 1)
    If strWork = "$" Then
    ElseIf Not strWork Like "*[!A-Z]*" = True Then
    Else
        strRows = strRows & strWork
    End If
Next i

'残った文字列をカンマで区切って配列へ
If InStr(strRows, ",") > 0 Then
    AddressArray = Split(strRows, ",")
Else
    ReDim AddressArray(1)
    AddressArray(1) = strRows
End If

'「:」を展開して、列番号を配列へ
r = 0
For Each a In AddressArray
    If InStr(a, ":") > 0 Then
        lngComma = InStr(a, ":")
        s = Mid(a, 1, lngComma - 1)
        e = Mid(a, lngComma + 1, Len(a) - lngComma)
        For i = s To e
            r = r + 1
            ReDim Preserve lngSelectRows(r)
            lngSelectRows(r) = i
        Next i
    Else
        r = r + 1
        ReDim Preserve lngSelectRows(r)
        lngSelectRows(r) = CLng(a)
    End If
Next a

'デバッグ文
If DebugFlag = True Then
    For Each a In lngSelectRows
        Debug.Print "変換後"; a
    Next
End If

End Sub

タイトルとURLをコピーしました