2

我知道 vlookup 只返回一个结果，但我正在寻找一种方法来搜索 2 列并返回与此查询匹配的所有结果：

SUBSTITUTE("*"&C2&"*"," ","*")

这样它也会返回类似的匹配项。我能够返回第一个匹配项（通过 vlookup），但我需要返回所有匹配项并将它们显示在一行中。

如果它会创建一个数组，我可以显示行中的第一个匹配与数组中的第一个元素，显示第二个匹配与第二个元素.. 等等。

到目前为止的VBA：

Function Occur(text, occurence, column_to_check)
  newarray = Split(text, " ")

  Dim temp As New Collection
  Dim intX As Integer

   For i = 1 To 90000
   intX = 1
        For j = 0 To Len(newarray)
             If Not InStr(Range(column_to_check + i).Value, newarray(j)) Then
                intX = 0
             End If
        Next j
        Exit For
        If intX = 1 Then
            temp.Add (Cells(i, column_to_check))
        End If
    Next i

End Function

谢谢！

4

2 回答 2

2

使用脚本字典和一些数组/范围操作。我在大约 30,000 行上进行了测试，它返回了大约 10,000 个匹配，比我眨眼的速度快。

Sub TestWithoutRE()
    Dim dict As Object
    Dim srchStrings() As String
    Dim s As Variant
    Dim colsToSearch As Range
    Dim cl As Range
    Dim allMatch As Boolean
    Dim matchArray As Variant

    'Define the strings you're looking for
    srchStrings = Split([C2], " ")

    'Define the ranges to search:
    Set colsToSearch = Range("F1:G33215")

    'Build a dictionary of the column data
    Set dict = CreateObject("Scripting.Dictionary")
    For Each cl In colsToSearch.Cells
        allMatch = True 'this will be set to false on the first non-matching value, no worries
        'Make sure each word is in the cell's value:
        For Each s In srchStrings
            If InStr(1, LCase(cl), LCase(s)) = 0 Then
                allMatch = allMatch + 1
                Exit For  'exit this if ANY substring is not found
            End If
        Next
        If allMatch Then
            '## As long as all strings were found, add this item to the dictionary
            dict.Add cl.Address, cl.Value
        End If
    Next

    '## Here is your array of matching values:
    matchArray = dict.Items


End Sub

基本上，我将您的搜索参数 ( C2) 拆分为一个数组。然后，我迭代这些列中的每个单元格，针对拆分数组的每个元素进行测试C2。如果没有找到来自的任何单词，C2那么我将其作为部分匹配忽略，您只是在寻找两个匹配的单词，没有特定的顺序。

如果两个单词都匹配，则将该值添加到字典对象。

然后，您可以通过引用dictionary.Itemswhich 返回一个数组来访问所有匹配的值。

于 2013-09-13T20:50:46.527 回答
1

尝试这个。您可以将其用作数组公式，选择合理数量的单元格来显示结果，或者在代码中使用它并以您喜欢的任何方式转储到工作表中。

它接受要搜索的单个字符串（它会拆分并测试单个字符串中的每个单词），然后是要搜索的字符串、范围或数组的 Param 数组。它返回一个匹配数组，因此您可以将其用作数组公式或在代码中用作任何其他数组。

使用示例：

  • =GetAllMatches("two three",A1:A5)具有单个连续范围的示例
  • =GetAllMatches("two three",A1,A3:A20,B5:B8,D1)'非连续单元格的例子
  • =GetAllMatches("two three",{"one two","three two","one two three"})数组示例
  • =GetAllMatches("two three","one two","one","three two","one two three")字符串示例
  • For each match in GetAllMatches(blah,blahblah):Debug.Print match:Next match在代码中而不是公式中使用的示例

您可能需要调整口味，但我已经评论了它在代码中的作用。

代码示例：

Public Function GetAllMatches(searchFor As String, ParamArray searchWithin()) As Variant

    'I use a ParamArray to handle the case of wanting to pass in non-contiguous ranges to search other
    'e.g. Blah(A1,A2,A3,C4:C10,E5)
    'nice little feature of Excel formulae :)

    Dim searchRange, arr, ele, searchComponents
    Dim i As Long
    Dim results As Collection
    Dim area As Range
    Set results = New Collection

    'generate words to test
    searchComponents = Split(searchFor, " ")

    For Each searchRange In searchWithin
        If TypeOf searchRange Is Range Then 'range (we test to handle user passing in arrays)
            For Each area In searchRange.Areas 'we enumerate to handle multi-area ranges
                arr = area.Value
                If VarType(arr) < vbArray Then 'we test to handle single cell areas
                    If isMatch(arr, searchComponents) Then results.Add arr 'is a match so add to results
                Else 'is an array, so enumerate
                    For Each ele In arr
                        If isMatch(ele, searchComponents) Then results.Add ele  'is a match so add to results
                    Next ele
                End If
            Next area
        Else
            Select Case VarType(searchRange)
                Case Is > vbArray 'user passed in an array not a range
                    For Each ele In searchRange 'enumerate, not iterate, to handle multiple dimensions etc
                        If isMatch(ele, searchComponents) Then results.Add ele  'is a match so add to results
                    Next ele
                Case vbString
                    If isMatch(searchRange, searchComponents) Then results.Add searchRange  'is a match so add to results
                Case Else 'no idea - return an error then fail fast (suppressed if called by an excel formula so ok)
                    GetAllMatches = CVErr(XlCVError.xlErrRef)
                    Err.Raise 1, "GetAllMatches", "Invalid Argument"
            End Select
        End If
    Next searchRange

    'Process Results
    If results.Count = 0 Then 'no matches
        GetAllMatches = CVErr(XlCVError.xlErrNA) 'return #N/A
    Else
        'process results into an array
        ReDim arr(0 To results.Count - 1)
        For i = 0 To UBound(arr)
            arr(i) = results(i + 1)
        Next i
        GetAllMatches = arr 'Return the array of matches
    End If
End Function
Private Function isMatch(ByRef searchIn, ByRef searchComponents) As Boolean
    Dim ele
    For Each ele In searchComponents
        If Not (InStr(1, searchIn, ele, vbTextCompare) > 0) Then
            Exit Function
        End If
    Next ele
    isMatch = True
End Function

电子表格示例：

one                  
one two         
one two three           
one three two           
four three one two

结果： one two three one three two four three one two

于 2013-09-13T20:37:00.110 回答