Faster way to Vlookup and return multiple results?

Question

I have looked for over a day here in Stackoverflow and cannot find an answer to what I am trying to do. All I need is a vba code that Vlookups and return the multiple results,

Eg; the lookup value is in sheet1 A1, data is in sheet2 columns A1:B40000, match the values in sheet2 A1:A40000 and returns the values from Sheet2 column B1:B40000.

Note:Its possible to find upto 5000 matches in sheet2 A1:A40000.

I have tried several ways to do this, such as Array formula (VERY SLOW), UDF (SLOW), VBA-AutoFilter(SLOW). Is there any way to do this quickly?

Can anyone help? Thanks a lot in advance!

Answer 1

Code tested with 40,000 entries, and this completes basically instantly:

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim wb As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim vLoookupVal As Variant
    Dim vValues As Variant
    Dim aResults() As Variant
    Dim lResultCount As Long
    Dim i As Long
    Dim lIndex As Long

    Set wb = ActiveWorkbook
    Set ws1 = Me                    'This is the sheet that contains the lookup value
    Set ws2 = wb.Sheets("Sheet2")   'This is the sheet that contains the table of values

    Application.EnableEvents = False

    If Not Intersect(Target, ws1.Range("A1")) Is Nothing Then
        ws1.Columns("B").ClearContents   'Clear previous results
        vLoookupVal = Intersect(Target, ws1.Range("A1")).Value
        lResultCount = WorksheetFunction.CountIf(ws2.Columns("A"), Target.Value)
        If lResultCount = 0 Then
            MsgBox "No matches found for [" & vLoookupVal & "]", , "No Matches"
        Else
            ReDim aResults(1 To lResultCount, 1 To 1)
            lIndex = 0
            vValues = ws2.Range("A1:B" & ws2.Cells(ws2.Rows.Count, "A").End(xlUp).Row).Value
            For i = LBound(vValues, 1) To UBound(vValues, 1)
                If vValues(i, 1) = vLoookupVal Then
                    lIndex = lIndex + 1
                    aResults(lIndex, 1) = vValues(i, 2)
                End If
            Next i
            ws1.Range("B1").Resize(lResultCount).Value = aResults
        End If
    End If

    Application.EnableEvents = True

End Sub

Answer 2

Maybe your AutoFilter code wasn't like this one?

Private Sub Main()
    Dim lookUpVal As Variant

    lookUpVal = Worksheets("Sheet1").Range("A1").Value
    With Worksheets("Sheet2")  
        With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
            If WorksheetFunction.CountIf(.Cells, lookUpVal) = 0 Then Exit Sub
            .AutoFilter field:=1, Criteria1:= lookUpVal
            .Resize(,2).SpecialCells(xlCellTypeVisible).Copy Worksheets("Sheet1").Range("B1")
        End With
        .AutoFilterMode= False
    End With
End Sub

Answer 3

数据透视表可以加快速度，您可以将过滤器用作搜索功能吗？