Excel Vba: Creating loop that checks if the values in column A matches and copy all the rows to a new spreadsheet - vba

Question

I need to select all the rows in column A that have the same the value and paste them to a new spreadsheet named with the copied name.
In the example picture when I run macro and input value Banana I should get all the rows that contain banana in column A.
I found following vba code from the internet and tried to modify it to my needs but I'm stuck:
Sub LookForAllSameValues()
Dim LSearchRow As Integer
Dim LCopyToRow As Integer
On Error GoTo Err_Execute
'Start search in row 4
LSearchRow = 2
'Start copying data to row 2 in Sheet2 (row counter variable)
LCopyToRow = 2
Uname = InputBox("Test")
ActiveWorkbook.Worksheets.Add.Name = Uname
While Len(Range("A" & CStr(LSearchRow)).Value) > 0
'If value in column E = "Mail Box", copy entire row to Sheet2
If Range("A" & CStr(LSearchRow)).Value = Uname Then
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
'Paste row into Sheet2 in next row
Sheets(Uname).Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste
'Move counter to next row
LCopyToRow = LCopyToRow + 1
'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select
End If
LSearchRow = LSearchRow + 1
Wend
'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select
MsgBox "All matching data has been copied."
Exit Sub
Err_Execute:
MsgBox "An error occurred."
End Sub
This code almost works. It asks user to input string to search and then it creates a new worksheet named as this one. The problem lies in the loop, I debugged the code and for some reason it just skips copy paste loop
How do I get the loop working?
Output when the code is run:

Answer 1

I'm assuming you're testing this on the data shown above.
Your code states that LSearch Row = 2 and therefore your search will begin in cell A2. I'd therefore assume your loop is never executing because Len(Range("A2")) equals 0 (the cell is empty) and the loop immediately exits. This also means that if any cell in column A is empty the loop will end there even if there is more data below it.
Instead try using a For..Next loop as shown below which will run from row 2 to the last used row in the active sheet, regardless of the cell contents.
Public Sub FindAndCreateNew()
Dim strFind As String
Dim i As Long, j As Long
Dim wsFind As Worksheet
Dim wsPaste As Worksheet
'Get value to search for
strFind = InputBox("Test")
'Create object reference to the current worksheet
Set wsFind = ActiveSheet
'Create a new worksheet with object reference and then rename it
Set wsPaste = Worksheets.Add
wsPaste.Name = strFind
'Paste starting at row 2 in wsPaste
j = 2
'Start searching from row 2 of wsFind, continue to end of worksheet
For i = 2 To wsFind.UsedRange.Rows.Count
If wsFind.Range("A" & i) = strFind Then
'Copy row i of wsFind to row j of wsPaste then increment j
wsFind.Range(i & ":" & i).Copy Destination:=wsPaste.Range(j & ":" & j)
j = j + 1
End If
Next i
End Sub
P.S. It's also worth noting that the use of .Select is generally avoidable and it can slow the program down considerably as well as making it less readable. For example this:
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy
Could be represented with just one statement as below:
'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Copy

Answer 2

As commented, try this:
Sub test()
Dim sh1 As Worksheet, sh2 As Worksheet
Dim rng As Range
Dim uname As String
Set sh1 = Sheet1: uname = InputBox("Input")
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
If Len(uname) = 0 Then MsgBox "Invalid input": Exit Sub
Set sh2 = ThisWorkbook.Sheets.Add(after:= _
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
On Error Resume Next
sh2.Name = uname: If Err.Number <> 0 Then MsgBox "Data already copied": _
sh2.Delete: Exit Sub
On Error GoTo 0
With sh1
.AutoFilterMode = False
Set rng = .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
rng.AutoFilter 1, uname
On Error Resume Next
rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy sh2.Range("A1")
If Err.Number <> 0 Then MsgBox "Data not found" _
Else MsgBox "All matching data has been copied"
.AutoFilterMode = False
On Error GoTo 0
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub