【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

おわりに

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

Range の左上セル座標を知るためのヒントになった。
- 【Excel VBA】Rangeオブジェクトの左上のセルを取得する方法は？… – 人力検索はてな
A1 参照形式から R1C1 参照形式へ変換する方法を知れた。
- Application.ConvertFormula メソッド (Excel)
- Office TANAKA – Excel VBA Tips[相対参照と絶対参照を変換する]
R1C1 参照形式の座標文字列から行番号を取り出す方法を知れた。
- Excel VBA 入門講座
LIKE による部分一致の書き方を確認できた。
- Excel(エクセル)VBA入門：Findメソッド,Like演算子を使った検索
Cells.Adress の使い方を確認できた。
- ExcelVBAでセルの行列番号を取得するAddressプロパティまとめ *Ateitexe

以上です。

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

VBA コード

おまけ。却下したやり方

WorksheetFunction.Match 関数概要

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

おわりに

関連

コメントを残すコメントをキャンセル