Help to Adjust lookup and copy script

[kelly mort]

This code is to take the user input from the InputBox and then compare them with the last two characters of the contents of two consecutive rows. Then copy all those rows with the match.

But the version down here only deals with it when the match is found in the first two rows of the dataset. And it only copies the matched cell values instead of the entire data in the row. Here the data copied are pasted horizontally. I want it done vertically

Can someone help fix it for me?

Sub FindPartialMatches(ByVal Text As String)


    Dim RngDst  As Range
    Dim RngSrc  As Range
    Dim RngEnd  As Range
    Dim WksDst  As Worksheet
    Dim WksSrc  As Worksheet
    
        Set WksSrc = ActiveSheet
        Set WksDst = Worksheets("Sheet2")
        
        Set RngDst = WksDst.Range("A1")
        
        Set RngSrc = WksSrc.Range("B1:H" & WksSrc.UsedRange.Rows.Count)
        Set RngEnd = RngSrc.Find("*", RngSrc.Cells(RngSrc.Rows.Count, 1), xlValues, xlWhole, xlByRows, xlPrevious, False, False, False)
        Set RngSrc = RngSrc.Resize(RowSize:=RngEnd.Row - RngSrc.Row + 1)
        
        Addx = RngSrc.Address
        
        vInputs = Split(Text, ",")
        
        With RngSrc
            For c = 1 To .Columns.Count
                For r = 1 To .Rows.Count - 1
                    If .Cells(r, c) Like "*" & vInputs(0) Then
                        If .Cells(r + 1, c) Like "*" & vInputs(1) Then
                            RngDst.Value = .Cells(r, c)
                            RngDst.Offset(0, 1).Value = .Cells(r + 1, c)
                            Set RngDst = RngDst.Offset(1, 0)
                        End If
                    End If
                Next r
            Next c
        End With
        
End Sub


Sub Test  ()
Dim vInputs 
vInputs = InputBox  ("Enter 2 numbers separated by comma ")
End Sub

 

[kelly mort]

Still need help with this.

Can someone confirm it is possible?

Regards
Kelly