pgbigorokuのブログ

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

EXCEL VBA 選択セルのデータを強制的に文字列化する（'を付ける）

XLOOKUPやVLOOKUPを利用するときに、文字列と数値が混在して、上手く情報を取り出せない事はありませんか？
このマクロは、セルを選択した後「nsub選択セルのデータを強制的に文字列化する」を実行すると
すべて文字列にします。

'
'　選択セルのデータを強制的に文字列化する（'を付ける）
'https://pgbigoroku.hatenablog.com/entry/2022/08/30/235553
'2022/8/30
Public Sub nsub選択セルのデータを強制的に文字列化する()
    Call nisubセルのデータを強制的に文字列化する(Selection)
End Sub

'
'　セルのデータを強制的に文字列化する（'を付ける）
'https://pgbigoroku.hatenablog.com/entry/2022/08/30/235553
'2022/8/30
Public Sub nisubセルのデータを強制的に文字列化する(ByRef rng対象セル As Range)
    Dim varCell As Variant
    For Each varCell In rng対象セル.Cells
        If Left(varCell.Value, 1) = "'" Then
            '何も処理をしない
        Else
            varCell.Value = "'" & varCell.Value
        End If
    Next
End Sub

Windowsに入れているアプリ

個人的にWindowsに入れているアプリです。

・PowerToys　マウスの場所を探したり、画面分割したり便利！
github.com
・LetsView　Androidの画面共有
・TeraTerm　ターミナル操作
・7-ZIP　　　解凍
・PacketiX VPN　VPNソフト
・Diffuse　　DF
・PowerShell　ターミナル
・秀丸エディタ　NOTEPADがわり

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

EXCEL VBA コレクション　Itemのすべての文字を結合する。

コレクションの中に入れた文字列をすべて結合して出したいときはありませんか？
例えば、

コレクションに

Item（１）わたしは
Item（２）ユニバに
Item（３）いきたいです。

という内容を入れていた場合に
テキストで

わたしは
ユニバに
いきたいです。

という感じです。
FORで回すと、改行が残り結構煩雑なんですよね（笑）
というわけで関数、「nistrコレクションが文字列の場合結合する」を作ってみました。

Public Sub test()
    Dim cll As New Collection
    cll.Add "わたしは"
    cll.Add "ユニバに"
    cll.Add "行きたいです"
    Debug.Print nistrコレクションが文字列の場合結合する(cll, vbCr)
    
    

End Sub


'
'　コレクションが文字列の場合結合する。
'https://pgbigoroku.hatenablog.com/entry/2022/08/25/094908
'2021/8/21
Public 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

EXCEL VBA コレクション　コレクションのすべてのアイテムを削除する。

コレクションのアイテムを削除したいときってありませんか？
コレクションは全アイテムの削除機能が内容ですので、
関数を作りました。

※ディクショナリは全削除が用意されいます。

Public Sub test2()
    Dim cll As New Collection
    cll.Add "AAA"
    Debug.Print cll.Count   '1
    cll.Add "AAA"
    Debug.Print cll.Count   '2
    cll.Add "AAA"
    Debug.Print cll.Count   '3
    psubCollectionClear cll
    Debug.Print cll.Count    '0
End Sub

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

EXCEL VBA セルの場所指定をA1の文字列形式で取得する。 

Public Sub test()

    Debug.Print pstrA1形式FromR1C1形式(1, 2, 3, 4) '$B$1:$D$3
    

End Sub

'
'  セルの場所指定を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