如何编辑此返回多个匹配VBA代码以在下面输入匹配项

Question

我有这个VBA代码。它本质上是一个vlookup，但返回多个匹配项。但是，它会在desW值("A1"(旁边输入匹配项。逐列显示。我如何编辑它以输入下面的数据？此外，我希望能够编辑返回匹配位置，因为查找值将在"A1"中，但我希望一些匹配位于A列和B列中。这将通过使用不同的列号多次运行此代码在Sheet1上搜索来完成。

我已经尝试过多次编辑代码，但都没有成功。要么它不从底部输入数据，要么它不返回所有匹配项。目前，我使用数组公式来实现这一点，但它会大大降低我的文件速度。这是代码。谢谢大家。

Sub ReturnMultipleMatches()
Application.ScreenUpdating = False
Dim LastRow1 As Long, LastRow3 As Long, rng As Range, sAddr As String, _
Val As Range, lCol As Long, desWS As Worksheet, srcWS As Worksheet
Set desWS = Sheets("Sheet3")
Set scrWS = Sheets("Sheet1")
LastRow1 = scrWS.Cells.Find("*",   SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
LastRow3 = desWS.Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

For Each rng In desWS.Range("A1")

Set Val = scrWS.Range("A2:AH" &  LastRow1).Find( _
rng, LookIn:=xlValues, lookat:=xlWhole)

If Not Val Is Nothing Then
sAddr = Val.Address
Do
lCol = desWS.Cells(rng.Row, desWS.Columns.Count).End(xlToLeft).Column + 1
desWS.Cells(rng.Row, lCol) = scrWS.Cells(Val.Row, 30)
Set Val = scrWS.Range("A2:AH" & LastRow1).FindNext(Val)
Loop While Val.Address <> sAddr
sAddr = ""
End If
Next rng
Application.ScreenUpdating = True
End Sub 

Answer 1

未测试：

Sub ReturnMultipleMatches()
Application.ScreenUpdating = False
Dim LastRow1 As Long, rng As Range, sAddr As String, cDest As Range, _
Val As Range, lCol As Long, desWS As Worksheet, srcWS As Worksheet
Dim rngSrch As Range

Set srcWS = Sheets("Sheet1")
Set desWS = Sheets("Sheet3")

LastRow1 = srcWS.Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row

Set rngSrch = srcWS.Range("A2:AH" & LastRow1)

For Each rng In desWS.Range("A1").Cells

Set Val = rngSrch.Find(rng.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not Val Is Nothing Then
'first empty cell below the value being searched
Set cDest = desWS.Cells(Rows.Count, rng.Column).End(xlUp).Offset(1, 0) 
sAddr = Val.Address
Do
cDest.Value = Val.EntireRow.Cells(30).Value
Set cDest = cDest.Offset(1, 0) 'next row down
Set Val = rngSrch.FindNext(Val)
Loop While Val.Address <> sAddr
sAddr = ""
End If

Next rng
Application.ScreenUpdating = True
End Sub