Vba 以更快的方式访问Vlookup并返回多个结果？

我在Stackoverflow已经找了一天多了，找不到我想要做的事情的答案。 我所需要的只是一个vba代码，它可以Vlookups并返回多个结果

Eg；查找值位于sheet1 A1中，数据位于sheet2列A1:B40000中，与sheet2 A1:A40000中的值匹配，并返回sheet2列B1:B40000中的值

注：在表2 A1:A40000中可以找到多达5000个匹配项

我已经尝试了几种方法，例如数组公式（非常慢）、UDF（慢）、VBA自动过滤器（慢）。 有什么方法可以快速做到这一点吗

有人能帮忙吗？

---

提前多谢

Pivot table将加快速度，您可以使用过滤器作为搜索功能？

代码测试了40000个条目，基本上立即完成：

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

---

也许你的自动筛选代码不是这样的

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

---

你对“慢”的定义是什么？（我没有想到，

自动筛选

的速度会非常慢。）也许你可以发布你用

自动筛选

方法尝试过的代码，我们也许可以找出它的错误。@YowE3K加载结果大约需要30..40秒。我也会建议使用自动筛选。所以现在我很想看看你的代码…@YowE3K Checkout Tigeravatar的回答现在我很想知道哪个代码更快…谢谢你的朋友！！它就像一个符咒！您好，也可以从Sheet2 C列检索数据吗？提前谢谢！