copying specific entries from table based on "name" (find function) vba - vba

Question

I have a code that's intended to:
1) Find a name from a table using a searchbox
2) Copy cells in the row with the name on to another sheet
3) This should work for all entries in the table associated with this name.
Code sample:
Sub Printout()
Dim LR2 As Long
Dim c As Variant
Dim txt As Variant
c = InputBox("Enter Last Name")
txt = CStr(c)
Sheets("B").Select
Sheets("B").Range("K3").Value = txt
Sheets("A").Select
Sheets("A").Columns(2).Find(What:=txt, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True).Activate
LR2 = Sheets("A").Cells(Rows.Count, "a").End(xlUp).Row
Sheets("A").Range(Cells(ActiveCell.Row, 2), Cells(LR2, 10)).Select
Selection.Copy Destination:=Sheets("B").Range("A2:J2")
End Sub
Problem:
Currently, the code doesn't just copy the specific name from the searchbox input, but all entries under the name as well. Ie if "Johnson" is entry 3, 6, and 11, I want columns 2 to 10 for those three rows. Currently it finds the first entry and seem to copy everything in columns 2 to 10 underneath it. Can someone please help me troubleshoot this code so that I can make it do what I want?
Thanks in advance!

Answer 1

this should be what youre after. Season to taste but itll do what you want
Private Sub derp()
Dim this As String
this = InputBox("Enter Last Name")
Dim rng As Range
Dim rcell As Range
Dim lastrow As Long
Dim that As Variant
lastrow = ThisWorkbook.Sheets("Sheet3").UsedRange.Rows.Count
Set rng = ThisWorkbook.Sheets("Sheet2").Range("A1:a40")
For Each rcell In rng.Cells
If rcell.Value <> vbNullString Then
If rcell.Value = this Then
that = ThisWorkbook.Sheets("Sheet2").Range("A" & rcell.Row & ":H" & rcell.Row)
ThisWorkbook.Sheets("Sheet3").Range("A" & lastrow & ":H" & lastrow).Value2 = that
lastrow = lastrow + 1
End If
End If
Next rcell
End Sub

Answer 2

This is my best guess
Sub Printout()
Dim LR2 As Long
Dim c As Variant
Dim txt As Variant
Dim r As Range
Dim s As String
c = InputBox("Enter Last Name")
txt = CStr(c)
Sheets("B").Range("K3").Value = txt
With Sheets("A")
Set r = .Columns(2).Find(What:=txt, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not r Is Nothing Then
s = r.Address
Do
LR2 = Sheets("B").Cells(Rows.Count, "a").End(xlUp).Row
.Range(.Cells(r.Row, 2), .Cells(r.Row, 10)).Copy Destination:=Sheets("B").Range("A" & LR2)
Set r = .Columns(2).FindNext(r)
Loop While r.Address <> s
End If
End With
End Sub

Answer 3

It is sometimes problematic to work with code, that is not created by you. In your case, you want to select and copy the cells, which you have found in column 2.
If you take a look at this code and edit it a bit, you would be able to do it.
Option Explicit
Option Private Module
Sub Printout()
Dim txt As Variant
Dim rngUnion As Range
Dim rngCell As Range
txt = "vi"
With ActiveSheet
For Each rngCell In .Range(.Cells(1, 1), .Cells(9, 1))
If InStr(1, rngCell, txt) Then
If rngUnion Is Nothing Then
Set rngUnion = .Range(.Cells(rngCell.Row, 2), .Cells(rngCell.Row, 5))
Else
Set rngUnion = Union(rngUnion, .Range(.Cells(rngCell.Row, 2), .Cells(rngCell.Row, 5)))
End If
End If
Next rngCell
End With
rngUnion.Select
End Sub
Your ActiveSheet should like this:
What the code does:
It loops through the Cells from A1 to A9.
If it finds vi in one of those cells, it adds 4 cells of the same row to a union - rngUnion
At the end it selects a union, just to show you which one is it. You can copy the selection or copy the range, without selecting it.
Good luck, have fun!