【Excel VBA】指定ブックのワークシートの範囲から文字列が一致する場所を返すクラスのコード!

スポンサードリンク

仕様。何ができるクラスなの?

  • 検索文字列は複数渡すことができる。
  • 検索は完全一致、部分一致の両方に対応する。
  • 結果は A1 参照形式、R1C1 参照形式のどちらでも得られる。例えばこんなイメージ。
    • A1 参照形式: (“A1”, “B3”, “C6”)
    • R1C1 参照形式: ((1,1), (2,3), (3,6))

VBA コード

''' <summary>
''' 指定ブックのワークシートの範囲から文字列が一致する場所を返すクラスです。
''' </summary>

Option Explicit

Private mvntValues As Variant
Private mvntRangeLeftUpIndexes As Variant
Private mcolSearchWords As Collection
' 2 次元配列を検索してヒットした要素のインデックス
' (Array(1 次元目インデックス, 2 次元目インデックス))
' を格納したコレクション
Private mcolHitIndexes As Collection

''' <summary>
''' 初期化処理を実行します。
''' </summary>
''' <param name="strBook">対象ブック名</param>
''' <param name="strSheet">対象シート名</param>
''' <param name="strRange">対象範囲名</param>
''' <param name="vntWords">検索文字列配列</param>
Public Sub Init( _
    ByVal strBook As String, _
    ByVal strSheet As String, _
    ByVal strRange As String, _
    ByVal vntWords As Variant)
    ' 変数をセット
    Dim r As Range: Set r = Workbooks(strBook).Sheets(strSheet).range(strRange)
    mvntValues = r.Value
    mvntRangeLeftUpIndexes = GetLUArray(r)
    Set mcolSearchWords = New Collection
    Dim word As Variant
    For Each word In vntWords
        Call mcolSearchWords.Add(word)
    Next word
End Sub

''' <summary>
''' Range の左上のセルの行番号、列番号を返します。
''' </summary>
''' <param name="r">Range オブジェクト</param>
''' <returns>
''' インデックス 0 要素に Range 左上セルの行番号を格納し、
''' インデックス 1 要素に Range 左上セルの列番号を格納した配列
'''</returns>
Private Function GetLUArray(ByVal r As Range) As Variant
    ' Range の左上のセルアドレスを R1C1 参照形式で取得
    Dim address As String: address = Application.ConvertFormula(r.Item(1).address, xlA1, xlR1C1)
    Dim lngRPosition As Long: lngRPosition = InStr(address, "R")
    Dim lngCPosition As Long: lngCPosition = InStr(address, "C")

    ' "R" と "C" の間が行番号
    Dim rowNum As Long: rowNum = Mid(address, lngRPosition + 1, lngCPosition - lngRPosition -1)
    ' "C" より右が列番号
    Dim colNum As Long: colNum = Right(address, Len(address) - lngCPosition)

    GetLUArray = Array(rowNum, colNum)
End Function

''' <summary>
''' Range を検索し、検索文字列に一致する内容を格納したセルを探します。
''' </summary>
Public Sub Search()
    Set mcolHitIndexes = SearchByWords(mcolSearchWords, mvntValues)
End Sub

''' <summary>
''' Range を検索し、検索文字列に一致する内容を格納したセルを探します。
''' *検索文字列* の Like 検索を行います。
''' </summary>
Public Sub SearchWithLike()
    ' 検索対象文字列の最初と最後に * を付加
    Dim editedWords As Collection: Set editedWords = New Collection
    Dim word As Variant
    For Each word In mcolSearchWords
        Call editedWords.Add("*" & word & "*")
    Next word
    Set mcolHitIndexes = SearchByWords(editedWords, mvntValues)
End Sub

''' <summary>
''' 文字列が一致する場所を格納したコレクションを返します。
''' </summary>
''' <param name="words">検索文字列コレクション</param>
''' <param name="values">検索対象の 2 次元配列</param>
''' <returns>
''' インデックス 0 要素にヒットした引数配列の 1 次元目インデックスを格納し、
''' インデックス 1 要素にヒットした引数配列の 2 次元目インデックスを格納した配列を
''' 要素としたコレクション
'''</returns>
Private Function SearchByWords( _
    ByVal words As Collection, _
    ByVal values As Variant) As Collection
    Dim colHitIndexes As Collection: Set colHitIndexes = New Collection
    Dim word As Variant
    Dim hits As Collection
    Dim hit As Variant
    For Each word In words
        Set hits = SearchByWord(word, values)
        For Each hit in hits
            Call colHitIndexes.Add(hit)
        Next hit
    Next word

    Set SearchByWords = colHitIndexes
End Function

''' <summary>
''' 文字列が一致する場所を格納したコレクションを返します。
''' </summary>
''' <param name="word">検索文字列</param>
''' <param name="values">検索対象の 2 次元配列</param>
''' <returns>
''' インデックス 0 要素にヒットした引数配列の 1 次元目インデックスを格納し、
''' インデックス 1 要素にヒットした引数配列の 2 次元目インデックスを格納した配列を
''' 要素としたコレクション
'''</returns>
Private Function SearchByWord( _
  ByVal word As Variant, _
  ByVal values As Variant) As Collection
  Dim hits As Collection: Set hits = New Collection
  Dim i As Long, j As Long
  For i = LBound(values, 1) To UBound(values, 1)
      For j = LBound(values, 2) To UBound(values, 2)
          If values(i, j) Like word Then
              Call hits.Add(Array(i, j))
          End If
      Next j
  Next i

  Set SearchByWord = hits
End Function

''' <summary>
''' 検索文字列に一致するセルの場所を返します。
''' </summary>
''' <returns>
''' インデックス 0 要素にヒットしたセルの行番号を格納し、
''' インデックス 1 要素にヒットしたセルの列番号を格納した配列を
''' 要素としたコレクション
'''</returns>
Public Function GetR1C1Locations() As Collection
    Dim row As Long
    Dim col As Long
    Dim locations As Collection: Set locations = New Collection
    Dim index As Variant
    For Each index In mcolHitIndexes
        ' Range 左上セル座標に 2 次元配列のヒットした要素のインデックスを加えて、
        ' ワークシートでのヒットしたセル位置を決定
        row = mvntRangeLeftUpIndexes(0) + index(0) - 1
        col = mvntRangeLeftUpIndexes(1) + index(1) - 1
        Call locations.Add(Array(row, col))
    Next index

    Set GetR1C1Locations = locations
End Function

''' <summary>
''' 検索文字列に一致するセルの場所を返します。
''' </summary>
''' <returns>A1 参照形式で表現した座標文字列のコレクション</returns>
Public Function GetA1Locations() As Collection
    Dim before As Collection: Set before = GetR1C1Locations
    Dim after As Collection: Set after = New Collection

    Dim r1c1 As Variant
    For Each r1c1 In before
        ' R1C1 参照形式を A1 参照形式へ変換
        Call after.Add(Cells(r1c1(0), r1c1(1)).address(False, False))
    Next r1c1

    Set GetA1Locations = after
End Function

確認用のテストコードです。

Option Explicit

' LocationSearcher.Search のテスト
Public Sub Test()
    ' 定義
    Dim b As String: b = "Book1.xlsm"
    Dim s As String: s = "Sheet1"
    Dim r As String: r = "B2:F6"
    ' 検索ワード
    Dim words As Variant: words = Array("cc", "d3")
    ' クラス生成・実行
    Dim ls As LocationSearcher: Set ls = New LocationSearcher
    Call ls.Init(b, s, r, words)
    Call ls.Search
    Dim r1c1s As Collection: Set r1c1s = ls.GetR1C1Locations
    Dim a1s As Collection: Set a1s = ls.GetA1Locations
    ' 確認
    Dim i As Long
    Dim result As String
    Dim expectR1c1s As Variant: expectR1c1s = Array(Array(3, 3), Array(4,3), Array(3, 4))
    For i = 1 To r1c1s.Count
        result = "予想: " & expectR1c1s(i - 1)(0) & expectR1c1s(i - 1)(1) & ". 結果: " & r1c1s(i)(0) & r1c1s(i)(1)
        If expectR1c1s(i - 1)(0) = r1c1s(i)(0) And expectR1c1s(i - 1)(1) = r1c1s(i)(1) Then
            Debug.Print "OK. " & result
        Else
            Debug.Print "NG. " & result
        End If
    Next i
    Dim expectA1s As Variant: expectA1s = Array("C3", "C4", "D3")
    For i = 1 To a1s.Count
        result = "予想: " & expectA1s(i -1) & ". 結果: " & a1s(i)
        If expectA1s(i -1) = a1s(i) Then
            Debug.Print "OK. " & result
        Else
            Debug.Print "NG. " & result
        End If
    Next i
End Sub

' LocationSearcher.SearchWithLike のテスト
Public Sub Test2()
    ' 定義
    Dim b As String: b = "Book1.xlsm"
    Dim s As String: s = "Sheet1"
    Dim r As String: r = "B2:F6"
    ' 検索ワード
    Dim words As Variant: words = Array("c", "d")
    ' クラス生成・実行
    Dim ls As LocationSearcher: Set ls = New LocationSearcher
    Call ls.Init(b, s, r, words)
    Call ls.SearchWithLike
    Dim r1c1s As Collection: Set r1c1s = ls.GetR1C1Locations
    Dim a1s As Collection: Set a1s = ls.GetA1Locations
    ' 確認
    Dim i As Long
    Dim result As String
    Dim expectR1c1s As Variant: expectR1c1s = Array(Array(3, 3), Array(4,3), Array(5, 3), Array(3, 4), Array(4,4), Array(5, 4))
    For i = 1 To r1c1s.Count
        result = "予想: " & expectR1c1s(i - 1)(0) & expectR1c1s(i - 1)(1) & ". 結果: " & r1c1s(i)(0) & r1c1s(i)(1)
        If expectR1c1s(i - 1)(0) = r1c1s(i)(0) And expectR1c1s(i - 1)(1) = r1c1s(i)(1) Then
            Debug.Print "OK. " & result
        Else
            Debug.Print "NG. " & result
        End If
    Next i
    Dim expectA1s As Variant: expectA1s = Array("C3", "C4", "C5", "D3", "D4", "D5")
    For i = 1 To a1s.Count
        result = "予想: " & expectA1s(i -1) & ". 結果: " & a1s(i)
        If expectA1s(i -1) = a1s(i) Then
            Debug.Print "OK. " & result
        Else
            Debug.Print "NG. " & result
        End If
    Next i
End Sub

そして、確認用エクセルワークシートです。

  • [Book1.xlsm]Sheet1
  • C3 セルを起点に下記を入力
cc d3 e3
cc d4 e4
c5 d5 e5

おまけ。却下したやり方

WorksheetFunction.Match 関数概要

検索するのに WorksheetFunction.Match 関数は適さなかった。2 次元の Range を検索範囲とするとヒットしなかった。

WorksheetFunction.Match 関数の特徴と確認コード

Match 関数の覚えておきたいと感じた特徴です。

  • Match 関数は英字の大文字と小文字は区別しない。

確認用のエクセルワークシートは上述したものと同じです。

Public Sub Test()
    Dim b As Workbook: Set b = Workbooks("Book1.xlsm")
    Dim s As Worksheet: Set s = b.Worksheets("Sheet1")
    Dim r As Range: Set r = s.Range("B2:F6")

    Dim result As Variant: result = Application.Match("cc", r, 0)
    If IsError(result) Then
        Debug.Print "なし"
    Else
        Debug.Print result
    End If
End Sub

おわりに

参考ページです。ありがとう存じます!

以上です。


スポンサードリンク

コメントを残す