VBA将从查找列表中返回所有匹配项

Question

我正在尝试实现一种VBA方法，以搜索名称列表并从提供的列表中返回匹配的所有实例。我需要返回的数据在A2：E11中。这可能会更大，我所包含的样本数据比我实际试图将其用于的数据要简单得多。我尝试查找的值在H3：H6范围内。如果要查找的查找值更多，则该值也可能更大。我尝试获取的输出在J3：N6中。目前，我使用的VBA脚本一次只能处理一个查询值。如果我只有一个查找值，则该方法效果很好。我想知道我必须对下面的脚本进行哪些更改，以使其能够针对我想做的事情起作用。同样，我尝试返回查找列表的所有匹配项，并将该数据复制到“输出”范围。我是VBA的新手，但我相信这是可能的。过去，由于类似的问题，我使用了index匹配数组来返回第n次匹配。该方法现在对我不起作用，因为我要用于此方法的数据集太大，并且计算时间太长。

任何建议，将不胜感激！谢谢大家！

'1. declare variables
'2. clear old search results
'3. find records that match criteria and paste them

'https://www.youtube.com/watch?v=QOxhRSCfHaw#action=share

Dim name As String 'What you are trying to match to
Dim finalrow As Integer 'Simply a final row helper
Dim i As Integer 'Row counter

Sheets("Sheet1").Range("R3:V15").ClearContents 'Clearing the previous output

name = Sheets("Sheet1").Range("P3").Value
finalrow = Sheets("Sheet1").Range("A1000").End(xlUp).Row 'This is simply going to a cell way below the data and searching upewards to get the final row

For i = 3 To finalrow 'Row your data starts
    If Cells(i, 1) = name Then
        Range(Cells(i, 1), Cells(i, 5)).Copy
        Range("R100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
        End If
Next i

Range("P3").Select

End Sub

Answer 1

请测试下一个代码：

Sub testMultipleLookup_NamesSearch()
 Dim sh As Worksheet, lastRow As Long, arr As Variant, arrLookUp As Variant
 Dim arrFin As Variant, i As Long, j As Long, t As Long, k As Long

 Set sh = ActiveSheet 'you can use here your sheet to be processed
 lastRow = sh.Range("A" & Rows.Count).End(xlUp).row
 arr = sh.Range("A2:E" & lastRow).Value 'put in an array the range to be processed
 ReDim arrFin(1 To 5, 1 To UBound(arr, 1)) 'the initial dimensions able to keep the maximum occurrences
                                           'it is reversed in terms of rows and columns, because only the last dimension can be changed at the end

 k = k + 1 'initialize the variable or arrFin (final) rows
 For t = 1 To 5
    arrFin(t, k) = arr(1, t) 'load the head of the table
 Next t
 arrLookUp = sh.Range("H3:H" & sh.Range("H" & Rows.Count).End(xlUp).row).Value 'Put in an array the Lookup_Names

 For i = 2 To UBound(arrLookUp, 1) 'start iteration of Lookup_Names
    For j = 1 To UBound(arr, 1)    'iterate between the array to be processed
        If arrLookUp(i, 1) = arr(j, 1) Then
            k = k + 1
            For t = 1 To 5
                arrFin(t, k) = arr(j, t) 'load all matching row in the final array
            Next t
        End If
    Next j
 Next i
 ReDim Preserve arrFin(1 To 5, 1 To k) 'keep only the values to be returned
 'drop the final array in the required range, at once
 sh.Range("R2").Resize(UBound(arrFin, 2), UBound(arrFin, 1)).Value = WorksheetFunction.Transpose(arrFin)
End Sub

Answer 2

请将此视为硬编码解决方案，因为我没有excel且没有尝试该解决方案。在您的示例中，您仅处理一个查询键值。您需要做的是创建另一个循环以考虑一系列查找键值。像这样的东西：

finalrow = Sheets("Sheet1").Range("A1000").End(xlUp).Row 
finalrowformultiple = Sheets("Sheet1").Range("H1000").End(xlUp).Row

For j = 3 To finalrowformultiple
    name = Cells(j ,8)
    For i = 3 To finalrow
            If Cells(i, 1) = name Then
            Range(Cells(i, 1), Cells(i, 5)).Copy
            Range("R100").End(xlUp).Offset(1, 0).PasteSpecial xlPasteFormulasAndNumberFormats
            End If
    Next i
Next j

此脚本将考虑H列中的每个查找值，而不是P3中的一个值。希望这会有所帮助。