Question

我正在尝试在工作表中搜索前3列中的值与3个条件的集合匹配的行。我正在使用这种线性搜索：

Function findRow(pName as string,fNo as string,mType as string) As Long

Dim rowCtr As Long

rowCtr = 2
While Not rowMatchesCriteria(rowCtr, pName,fNo,mType)
    rowCtr = rowCtr + 1
Wend
findRow=rowCtr

End Function



Function rowMatchesCriteria(row As Long, pName As String, fNo As String, mType As String) As Boolean

rowMatchesCriteria = dSheet.Cells(row,1)=pName _
                        And dSheet.Cells(row,2)=fNo _
                        And dSheet.Cells(row,3)=mType

End Function

我们可以假设，对于任何3个标准，只有一个匹配。但是，这很慢。 dSheet有大约35,000个条目要搜索，我需要执行大约400,000次搜索。

我查看了this question中的一些解决方案，虽然我确信使用AutoFilter或高级会比线性搜索更快，但我不明白如何获取行的索引过滤器返回。我正在寻找的是：

Sub makeUpdate(c1 as string,c2 as string,c3 as string)

Dim result as long

result = findRow(c1,c2,c3)

dSheet.Cells(result,updateColumn) = someUpdateValue

End Sub

一旦我应用了AutoFilter，如何实际返回我正在寻找的result行？

Answer 1

为了表现，你很难击败基于字典的查找表：

Sub FindMatches()

    Dim d As Object, rw As Range, k, t
    Dim arr, arrOut, nR, n

    t = Timer

    'create the row map (40k rows)
    Set d = GetRowLookup(Sheets("Sheet1").Range("A2:C40001"))

    Debug.Print Timer - t, "map"
    t = Timer

    'run lookups on the row map
    '(same values I used to create the map, but randomly-sorted)
    For Each rw In Sheets("sheet2").Range("A2:C480000").Rows
        k = GetKey(rw)
        If d.exists(k) Then rw.Cells(3).Offset(0, 1).Value = d(k)
    Next rw

    Debug.Print Timer - t, "slow version"
    t = Timer

    'run lookups again - faster version
    arr = Sheets("sheet2").Range("A2:C480000").Value
    nR = UBound(arr, 1)
    ReDim arrOut(1 To nR, 1 To 1)
    For n = 1 To nR
        k = arr(n, 1) & Chr(0) & arr(n, 2) & Chr(0) & arr(n, 3)
        If d.exists(k) Then arrOut(n, 1) = d(k)
    Next n
    Sheets("sheet2").Range("D2").Resize(nR, 1).Value = arrOut

    Debug.Print Timer - t, "fast version"

End Sub  


'create a dictionary lookup based on three column values
Function GetRowLookup(rng As Range)
    Dim d As Object, k, rw As Range
    Set d = CreateObject("scripting.dictionary")
    For Each rw In rng.Rows
        k = GetKey(rw)
        d.Add k, rw.Cells(1).Row 'not checking for duplicates!
    Next rw
    Set GetRowLookup = d
End Function

'create a key from a given row
Function GetKey(rw As Range)
    GetKey = rw.Cells(1).Value & Chr(0) & rw.Cells(2).Value & _
              Chr(0) & rw.Cells(3).Value
End Function

Answer 2

如果要对3列进行精确查找，可以使用一个简单的技巧来使用VLOOKUP：根据3列创建密钥。例如。如果要对列B，C，D执行查询，请根据三列（例如= B1＆amp; C1＆amp; D1）在A中创建一个键列。然后：

=VLOOKUP(lookupvalue1&lookupvalue2&lookupvalue3,A:D,{2,3,4},FALSE)

应该做神奇的事。

Answer 3

一个简单的解决方案可能是使用excel函数MATCH作为数组公式。 没有for-each循环所以我想这可以非常快。

公式将看起来例如喜欢这个MATCH（“A”＆amp;“B”＆amp;“C”，RANGE_1＆amp; RANGE_2＆amp; RANGE_3,0）

Option Explicit

Private Const FORMULA_TEMPLATE As String = _
    "=MATCH(""CRITERIA_1""&""CRITERIA_2""&""CRITERIA_3"",RANGE_1&RANGE_2&RANGE_3,MATCH_TYPE)"

Private Const EXACT_MATCH = 0

Sub test()
    Dim result
    result = findRow("A", "B", "C")
    Debug.Print "A,B,C was found on row : [" & result & "]"
End Sub

Function findRow(pName As String, fNo As String, mType As String) As Long

    On Error GoTo Err_Handler

    Dim originalReferenceStyle
    originalReferenceStyle = Application.ReferenceStyle
    Application.ReferenceStyle = xlR1C1

    Dim data As Range
    Set data = ActiveSheet.UsedRange

    Dim formula As String

    ' Add criteria
    formula = Replace(FORMULA_TEMPLATE, "CRITERIA_1", pName)
    formula = Replace(formula, "CRITERIA_2", fNo)
    formula = Replace(formula, "CRITERIA_3", mType)

    ' Add ranges where search
    formula = Replace(formula, "RANGE_1", data.Columns(1).Address(ReferenceStyle:=xlR1C1))
    formula = Replace(formula, "RANGE_2", data.Columns(2).Address(ReferenceStyle:=xlR1C1))
    formula = Replace(formula, "RANGE_3", data.Columns(3).Address(ReferenceStyle:=xlR1C1))

    ' Add match type
    formula = Replace(formula, "MATCH_TYPE", EXACT_MATCH)

    ' Get formula result
    findRow = Application.Evaluate(formula)

Err_Handler:
    ' Set reference style back
    Application.ReferenceStyle = originalReferenceStyle

End Function

输出：在行上找到A，B，C：[4]

Data:

Answer 4

为了改善最佳答案（多标准搜索），您需要检查重复项以避免错误。

'create a dictionary lookup based on three column values
Function GetRowLookup(rng As Range)
    Dim d As Object, k, rw As Range
    Set d = CreateObject("scripting.dictionary")
    For Each rw In rng.Rows
        k = GetKey(rw)
        if not d.exists(k) then
            d.Add k, rw.Cells(1).Row 'checking for duplicates!
        end if
    Next rw
    Set GetRowLookup = d
End Function

如何根据多个标准获取行？

4 个答案: