Find a string and copy the corresponding rows to the same sheet starting from a different column-CodePudding

My code tries to do this and paste just below the last row

 Sub btnFind_Click()

Dim strLastRow As String
Dim rngC As Range
Dim strToFind As String, FirstAddress As String
Dim wSht As Worksheet
Dim rngtest As String
Application.ScreenUpdating = False

Set wSht = Worksheets("NewS")
strToFind = InputBox("Enter the value to find")

With ActiveSheet.Range("A1:A121")
    Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
        If Not rngC Is Nothing Then
            FirstAddress = rngC.Address
            Do
                strLastRow = Worksheets("NewS").Range("A" & Rows.Count).End(xlUp).Row   1
                rngC.EntireRow.Copy wSht.Cells(strLastRow, 1)
                Set rngC = .FindNext(rngC)
            Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
        End If
End With

MsgBox ("Finished")

End Sub

The results are pasted just below the last row of the active sheet but I want the results to be pasted at column N3 as the start and also I dont want the actual string to be pasted (only the remaining column values in that row).

like the below image where I selected Value 2 as string.

CodePudding user response：

Try this:

Sub btnFind_Click()
    Dim rngC As Range, rngDest As Range
    Dim strToFind As String, FirstAddress As String
    Dim wSht As Worksheet
    Dim rngtest As String
    Application.ScreenUpdating = False
    
    Set wSht = Worksheets("NewS")
    strToFind = InputBox("Enter the value to find")
    
    Set rngDest = wSht.Range("N3") 'start pasting here
    
    With wSht.Range("A1:A121")
        Set rngC = .Find(what:=strToFind, LookAt:=xlPart)
        If Not rngC Is Nothing Then
            FirstAddress = rngC.Address
            Do
                rngC.Offset(0, 1).Resize(1, 10).Copy rngDest 'move one cell right and copy 10 cols
                Set rngDest = rngDest.Offset(1, 0)           'next destination row
                Set rngC = .FindNext(rngC)
            Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress
        End If
    End With
    
    MsgBox "Finished"
End Sub