プログラミングのメモ

プログラミングの学び直し備忘録

トップ > ExcelVBA > VBA：Excel ：検索（アドレス）

VBA：Excel ：検索（アドレス）

ExcelVBA

『シート全体』指定文字列のアドレス検索

参考

ðÉÄÍÜéZðõ·é(Find/FindNext/FindPrevious\bh) FExcel VBAb¦øeNjbNbExcel VBAðwÔÈçmoug

VBAでセルの検索を続けて行う（FindNext、FindPrevious） ｜ Excel作業をVBAで効率化

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『シート全体』指定文字列のアドレス検索
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_シート全体_指定文字列のアドレス検索()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim sShrStr As String
    sShrStr = "検索"
    
    Dim sRes() As String
    sRes = mth_GetCellAddress_Sheet( _
                                    ws, _
                                    sShrStr _
                                    )
    
    Set ws = Nothing

End Sub

'*************************************************************************
'機能   : シート全体、指定文字列のアドレス検索
'戻り値 : アドレス配列
'ARG1   : WorkSheet
'ARG2   : 検索文字列
'説明   :
'*************************************************************************
Public Function mth_GetCellAddress_Sheet( _
                                            ws As Worksheet, _
                                            sSrhString _
                                            ) As String()

    Dim sRes_Address() As String
    
    Dim v As Variant
    
    Dim rngFindCell As Range
    Dim rngFind_1st As Range
    Dim rngFind_List As Range
    
    '===========================
    '// 検索
    '===========================
    'LookIn:=xlValues 値検索
    'LookAt:=xlWhole 完全一致
    'MatchCase:=true 大文字と小文字を区別する(True)
    'MatchByte:=True 半角と全角を区別する(True)
    'SearchFormat 書式を検索しない(False)
    Set rngFindCell = ws.Cells.Find( _
                                    what:=sSrhString, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    MatchCase:=True, _
                                    MatchByte:=True, _
                                    SearchFormat:=False _
                                    )
    
    If rngFindCell Is Nothing Then
        Exit Function
    Else
        Set rngFind_1st = rngFindCell
        Set rngFind_List = rngFindCell
    End If
    
    '--------------------------------------------
    '// 検索 → Rangeリスト追加
    '--------------------------------------------
    Do
        '// 以降の検索条件も同一で検索
        Set rngFindCell = ws.Cells.FindNext(rngFindCell)
        
　　'// 検索不一致時はループを抜ける
        If rNext Is Nothing Then
            Exit Do
        End If

        '// 処理
        If rngFindCell.Address = rngFind_1st.Address Then
            Exit Do '// 最初に見つかったものと同じなら終了
        Else
            'Find_Listに追加していく
            Set rngFind_List = Union(rngFind_List, rngFindCell)
        End If
    Loop
    
    '---------------
    '// Result
    '---------------
    Dim i As Long: i = 0
    For Each v In rngFind_List
        ReDim Preserve sRes_Address(i)
        sRes_Address(i) = v.Address
        i = i + 1
    Next
    
    
    mth_Getアドレス_シート全体 = sRes_Address
    
    '---------------
    '// 後処理
    '---------------
    Set rngFindCell = Nothing
    Set rngFind_1st = Nothing
    Set rngFind_List = Nothing
    
End Function

『指定範囲（Range）』指定文字列のアドレス検索

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『指定範囲（Range）』指定文字列のアドレス検索
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_指定範囲_指定文字列のアドレス検索()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim rng As Range
    Set rng = ws.Range("B2:E23")
    
    Dim sShrStr As String
    sShrStr = "検索"
    
    Dim sRes() As String
    sRes = mth_GetCellAddress_Range( _
                                    rng, _
                                    sShrStr _
                                    )
    
    Set ws = Nothing

End Sub

'*************************************************************************
'機能   : 『指定範囲（Range）』指定文字列のアドレス検索
'戻り値 : アドレス配列
'ARG1   : Range
'ARG2   : 検索文字列
'説明   :
'*************************************************************************
Public Function mth_GetCellAddress_Range( _
                                            rng As Range, _
                                            sSrhString _
                                            ) As String()

    Dim sRes_Address() As String
    
    Dim v As Variant
    
    Dim rngFindCell As Range
    Dim rngFind_1st As Range
    Dim rngFind_List As Range
    
    '===========================
    '// 検索
    '===========================
    'what:=sSrhString
    'After:=
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    'LookIn:=xlValues 値検索
    'LookAt:=xlWhole 完全一致
    'SearchOrder:= 検索方向を指定する。
    '               列方向に検索する（xlByColumns）、
    '               行方向に検索する（xlByRows）
    'MatchCase:=true 大文字と小文字を区別する(True)
    'MatchByte:=True 半角と全角を区別する(True)
    '%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    'SearchDirection:= 前方に検索(xlNext：既定値)、
    '                   後方に検索(xlPrevious)
    'SearchFormat 書式を検索しない(False)
    '
    Set rngFindCell = rng.Find( _
                                    what:=sSrhString, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    MatchCase:=True, _
                                    MatchByte:=True, _
                                    SearchFormat:=False _
                                    )
    
    If rngFindCell Is Nothing Then
        Exit Function
    Else
        Set rngFind_1st = rngFindCell
        Set rngFind_List = rngFindCell
    End If
    
    '--------------------------------------------
    '// 検索 → Rangeリスト追加
    '--------------------------------------------
    Do
        '// 以降の検索条件も同一で検索
        Set rngFindCell = rng.FindNext(rngFindCell)
        
　　'// 検索不一致時はループを抜ける
        If rNext Is Nothing Then
            Exit Do
        End If

        '// 処理
        If rngFindCell.Address = rngFind_1st.Address Then
            Exit Do '// 最初に見つかったものと同じなら終了
        Else
            'Find_Listに追加していく
            Set rngFind_List = Union(rngFind_List, rngFindCell)
        End If
    Loop
    
    '---------------
    '// Result
    '---------------
    Dim i As Long: i = 0
    For Each v In rngFind_List
        ReDim Preserve sRes_Address(i)
        sRes_Address(i) = v.Address
        i = i + 1
    Next
    
    
    mth_GetCellAddress_Range = sRes_Address
    
    '---------------
    '// 後処理
    '---------------
    Set rngFindCell = Nothing
    Set rngFind_1st = Nothing
    Set rngFind_List = Nothing
    
End Function

『指定行』指定文字列のアドレス検索

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『指定行』指定文字列のアドレス検索
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_行指定_指定文字列のアドレス検索()
    
    '====================================
    '単一行:Rows(2)
    '連続行:Range("2:5")
    '離れた行:Range("2:3,5:8,12:12")
    '====================================

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim rng As Range
    Set rng = ws.Range("10:16")
    
    Dim sShrStr As String
    sShrStr = "検索"
    
    Dim sRes() As String
    sRes = mth_GetCellAddress_Range( _
                                    rng, _
                                    sShrStr _
                                    )
    
    Set ws = Nothing

End Sub

『指定行(1行)』指定文字列のアドレス検索

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『指定行(1行)』指定文字列のアドレス検索
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_1行指定_指定文字列のアドレス検索()
    
    '====================================
    '単一行:Rows(2)
    '連続行:Range("2:5")
    '離れた行:Range("2:3,5:8,12:12")
    '====================================

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim rng As Range
    Set rng = ws.Rows(10)
    
    Dim sShrStr As String
    sShrStr = "検索"
    
    Dim sRes() As String
    sRes = mth_GetCellAddress_Range( _
                                    rng, _
                                    sShrStr _
                                    )
    Set ws = Nothing

End Sub

『指定列』指定文字列のアドレス検索

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『指定列』指定文字列のアドレス検索
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_列指定_指定文字列のアドレス検索()
    
    '====================================
    '[Columns]
    ' 単一列:Columns("G")
    ' 単一列:Columns(2)
    ' 連続列:Columns("F:E")
    '-------------------------------------
    '[Range]
    ' 連続列:Range("E:F").EntireColumn
    ' 離れた列:Range("E:E,G:H")
    ' 離れた列:Range("E1,G1:H1").EntireColumn
    '====================================

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim rng As Range
    Set rng = ws.Range("E:E,G:H")
    
    Dim sShrStr As String
    sShrStr = "検索"
    
    Dim sRes() As String
    sRes = mth_GetCellAddress_Range( _
                                    rng, _
                                    sShrStr _
                                    )
    
    Set ws = Nothing

End Sub

『指定列(1列)』指定文字列のアドレス検索

'■■■■■■■■■■■■■■■■■■■■■■■■■
'// 『指定列(1列)』指定文字列のアドレス検索
'//
'■■■■■■■■■■■■■■■■■■■■■■■■■
Private Sub psub_1列指定_指定文字列のアドレス検索()
    
    '====================================
    '[Columns]
    ' 単一列:Columns("G")
    ' 単一列:Columns(2)
    ' 連続列:Columns("F:E")
    '-------------------------------------
    '[Range]
    ' 連続列:Range("E:F").EntireColumn
    ' 離れた列:Range("E:E,G:H")
    ' 離れた列:Range("E1,G1:H1").EntireColumn
    '====================================

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(1)
    
    Dim rng As Range
    Set rng = ws.Columns("G")
    
    Dim sShrStr As String
    sShrStr = "検索"
    
    Dim sRes() As String
    sRes = mth_GetCellAddress_Range( _
                                    rng, _
                                    sShrStr _
                                    )
    
    Set ws = Nothing

End Sub

文字列を検索して、指定アドレスを返す。(Collection)

Enum enmAddress
    Address = 1
    Row = 2
    Col = 3
End Enum

Sub test()

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(2)
    
    Dim cRes As Collection
    Set cRes = New Collection
    Call mth_GetCellAddress_InSheet(ws, "検索", enmAddress.Address, cRes)
    
    Debug.Print cRes.Count
    
End Sub

'**
'* 文字列を検索して、指定アドレスを返す。
'*
'* @arg     {ws}
'* @arg     {str}
'* @arg     {enmAddress}
'* @arg_ref {colc}
'* @arg_opt {}
'* @ret     {}
'*
'* @note
'*
Public Sub mth_GetCellAddress_InSheet( _
                                    ws As Worksheet, _
                                    sSrhString As String, _
                                    enmAddress As enmAddress, _
                                    ByRef colcRef As Collection _
                                    )

    Dim rngFindCell As Range
    Dim rngFind_1st As Range
    Dim rngFind_List As Range
    
    '===========================
    '// シート全体検索
    '===========================
    'LookIn:=xlValues 値検索
    'LookAt:=xlWhole 完全一致
    'MatchCase:=true 大文字と小文字を区別する(True)
    'MatchByte:=True 半角と全角を区別する(True)
    'SearchFormat 書式を検索しない(False)
    Set rngFindCell = ws.Cells.Find( _
                                    what:=sSrhString, _
                                    LookIn:=xlValues, _
                                    LookAt:=xlWhole, _
                                    MatchCase:=True, _
                                    MatchByte:=True, _
                                    SearchFormat:=False _
                                    )
    
    If rngFindCell Is Nothing Then
        Exit Sub
    Else
        Set rngFind_1st = rngFindCell
        Set rngFind_List = rngFindCell
    End If
    
    '--------------------------------------------
    '// 検索 → Rangeリスト追加
    '--------------------------------------------
    Do
        '// 以降の検索条件も同一で検索
        Set rngFindCell = ws.Cells.FindNext(rngFindCell)
        
        '// 処理
        If rngFindCell.Address = rngFind_1st.Address Then
            Exit Do '// 最初に見つかったものと同じなら終了
        Else
            'Find_Listに追加していく
            Set rngFind_List = Union(rngFind_List, rngFindCell)
        End If
    Loop
    
    '---------------
    '// Result
    '---------------
    Dim v
    For Each v In rngFind_List
        Select Case enmAddress
            Case Address: colcRef.Add (v.Address)
            Case Row:    colcRef.Add (v.Row)
            Case Col:    colcRef.Add (v.Column)
        End Select
    Next
    
    '// 重複削除
    Dim colcRes As Collection
    Set colcRes = New Collection
    Call mth_DelSameVal_colec(colcRes)
    
    '---------------
    '// 後処理
    '---------------
    Set rngFindCell = Nothing
    Set rngFind_1st = Nothing
    Set rngFind_List = Nothing
    
End Sub

'**
'* 重複削除
'*
'* @arg     {}
'* @arg_ref {colc}
'* @arg_opt {}
'* @ret     {}
'*
'* @note
'*  Dictionaryで配列要素をKey､Valを追加
'*  Key重複できないのでErrで追加不可
'*  Key(Val)値は、重複削除の値となる
'*
Public Sub mth_DelSameVal_colec(ByRef clctRefTg As Collection)
    
    Dim dic
    Dim i As Long
    
    Set dic = CreateObject("Scripting.Dictionary")

On Error Resume Next
    For i = 1 To clctRefTg.Count
        dic.Add clctRefTg.Item(i), clctRefTg.Item(i)
    Next
    
    '// コレクションクリア
    For i = 1 To clctRefTg.Count
        clctRefTg.Remove 1
    Next
    
    '// コレクション 再設定
    Dim vFE_Key
    For Each vFE_Key In dic
        clctRefTg.Add (vFE_Key)
    Next vFE_Key
            
    Set dic = Nothing

End Sub