从 find 和 findnext 结果创建范围[重复]

Question

我有一个查找功能，可以搜索一列，并且可能有多个结果。我想将其存储在一个范围内（例如，而不是单独的数组）。 这就是我所拥有的：

Dim searchRange As Range
Set searchRange = ActiveWorkbook.Sheets(SHEET).Range(SEARCHFOLDERCOLUMN & SEARCHSTARTROW & ":" & SEARCHFOLDERCOLUMN & lastRow)
'search for value
Dim searchResult As Range
Dim firstAddress As String
    
Set searchResult = searchRange.Find(what:=sSearchFolder, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
    
If Not searchResult Is Nothing The
  firstAddress = searchResult.Address
    Do
        'search for the next one
        Debug.Print searchResult.Address
        Set searchResult = searchRange.FindNext(searchResult)
        '^^^^^ union instead of this ???
        'avoid endless loop, when hitting back the first address
        If firstAddress = searchResult.Address Then
           'Set searchResult = tempSearchResult
            Exit Do
        End If
    Loop While Not searchResult Is Nothing
End If
Debug.Print "out of loop"

我的输出：

$M$125
$M$148
$M$161
out of loop

我怎样才能得到这样的范围： "$M$125, $M$148, $M$161" ？列（或行？）或 3 而不是我现在的 1。

感谢您的帮助。

Answer 1

引用“FindNext Multi Range”

Option Explicit

Sub DebugPrintCCRGtest()
' Needs 'DebugPrintCCRG', 'RefColumn' and 'RefCriteriaColumnRange'.

    DebugPrintCCRG ""
    DebugPrintCCRG "Yes"
    DebugPrintCCRG "No"
    DebugPrintCCRG "2"

' Example Results:
' A4,A8:A9,A17
' A2:A3,A7,A12:A14,A21
' A6,A15:A16,A18:A19
' A5,A10:A11,A20

End Sub

Sub DebugPrintCCRG( _
        ByVal Criteria As String)
' Needs 'RefColumn' and 'RefCriteriaColumnRange'.
    
    Dim sFirst As String: sFirst = "A2"
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
    
    Dim crg As Range: Set crg = RefColumn(ws.Range(sFirst))
    If crg Is Nothing Then Exit Sub
    
    Dim ccrg As Range: Set ccrg = RefCriteriaColumnRange(crg, Criteria)
    If ccrg Is Nothing Then Exit Sub
    
    Debug.Print ccrg.Address(0, 0)

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the one-column range from the first cell
'               of a range ('FirstCell') to the bottom-most non-empty cell
'               of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
    ByVal FirstCell As Range) _
As Range
    If FirstCell Is Nothing Then Exit Function
    
    With FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If lCell Is Nothing Then Exit Function
        Set RefColumn = .Resize(lCell.Row - .Row + 1)
    End With

End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Creates a reference to the range combined from all the cells
'               of a one-column range ('crg'), whose values are equal
'               to a string ('Criteria').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCriteriaColumnRange( _
    ByVal crg As Range, _
    ByVal Criteria As String) _
As Range
    
    If crg Is Nothing Then Exit Function
    
    Dim cCell As Range: Set cCell = crg.Find(Criteria, _
        crg.Cells(crg.Cells.Count), xlFormulas, xlWhole)
    If cCell Is Nothing Then Exit Function
        
    Dim drg As Range: Set drg = cCell
    Dim FirstAddress As String: FirstAddress = cCell.Address
    
    Do
        Set drg = Union(drg, cCell)
        Set cCell = crg.FindNext(cCell)
    Loop Until cCell.Address = FirstAddress

    If drg Is Nothing Then Exit Function
    
    Set RefCriteriaColumnRange = drg

End Function