How to edit this return multiple matches VBA code to input matches below?

[Indominus]

Hi, I have this VBA code that I found on this site. I have tweaked it a tiny bit for my needs. It essentially is a vlookup but returns multiple matches. However, it inputs the matches next to the desWs value (“A1”). Goes column by columns. How can I edit this to input the data below? Also I would like to be able edit the return matches location as the lookup value will be in “A1” but I would like some matches to go in column A and also column B. This will be done by running this code multiple times with different column numbers to search for on Sheet1.

I have tried editing editing the code a number of times with no luck. Either it doesn’t input the data down bottom or it doesn’t return all matches. Currently I use an array formula to do this but it slows down my file heavily. What I am looking for in my final result is shown in the attached picture. And here is the code. Thank you all.

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