Row copy tool

[fireslguk]

Any recommendations on vba for the following

In Sheet 1

Search for user “Matthew”

Select and copy the row Matthew and paste in sheet 2

Search for user “green”

Select and copy the row green and paste in sheet 2 underneath Matthew row

 

[My Aswer Is This]

Search where on the sheet?
Search Column A or Column B or ??

 

[fireslguk]

Good point

I think the name is in column C

 

[My Aswer Is This]

Try this will search column C

Not sure why you say I think

Do you mean we need to search all 15,000 columns each time?

Sub My_Find()
Application.ScreenUpdating = False
'Modified  8/7/2018  2:44:27 AM  EDT
Dim SearchString As String
Dim SearchRange As Range
Dim Lastrow As Long
Dim Lastrowa As Long
Dim r As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "C").End(xlUp).Row + 1
With Sheets(1)
    Lastrow = .Cells(Rows.Count, "C").End(xlUp).Row
    SearchString = InputBox("Search for user?")
    Set SearchRange = .Range("C2:C" & Lastrow).Find(SearchString, LookIn:=xlValues, lookat:=xlWhole)
    If SearchRange Is Nothing Then MsgBox "The Value" & vbNewLine & SearchString & vbNewLine & "Not Found" & vbNewLine & "I will now exit the script": Exit Sub
    r = SearchRange.Row
    .Rows(r).Copy Sheets(2).Rows(Lastrowa)
End With
Application.ScreenUpdating = True
End Sub

 

[fireslguk]

Try this will search column C

Not sure why you say I think

Do you mean we need to search all 15,000 columns each time?

Sub My_Find()
Application.ScreenUpdating = False
'Modified  8/7/2018  2:44:27 AM  EDT
Dim SearchString As String
Dim SearchRange As Range
Dim Lastrow As Long
Dim Lastrowa As Long
Dim r As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "C").End(xlUp).Row + 1
With Sheets(1)
    Lastrow = .Cells(Rows.Count, "C").End(xlUp).Row
    SearchString = InputBox("Search for user?")
    Set SearchRange = .Range("C2:C" & Lastrow).Find(SearchString, LookIn:=xlValues, lookat:=xlWhole)
    If SearchRange Is Nothing Then MsgBox "The Value" & vbNewLine & SearchString & vbNewLine & "Not Found" & vbNewLine & "I will now exit the script": Exit Sub
    r = SearchRange.Row
    .Rows(r).Copy Sheets(2).Rows(Lastrowa)
End With
Application.ScreenUpdating = True
End Sub

Lol because the file I want to extract from is at work so I need to check

Also this code at first glance is a once only use per person ?

I need the code to find the same 8 people every time I run it

 

[My Aswer Is This]

Ok:
You said:

I need the code to find the same 8 people every time I run it​

What 8 named people.
You have not provided those 8 names.

 

[fireslguk]

Ok:
You said:

I need the code to find the same 8 people every time I run it​

What 8 named people.
You have not provided those 8 names.

“Matthew”
“Green”
“Ali”
“Pop”
“Go”
“One”
“Red”
“Fox”

 

[My Aswer Is This]

Try this:

Sub Case_Using()
'Modified  8/7/2018  4:55:12 AM  EDT
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets(1).Activate
Lastrow = Sheets(1).Cells(Rows.Count, "C").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets(2).Cells(Rows.Count, "C").End(xlUp).Row
    For i = 1 To Lastrow
        MyVal = Cells(i, 3).Value
            With Cells(i, 1)
                Select Case MyVal
                    Case "Matthew", "Green", "Ali", "Pop", "Go", "One", "Red", "Fox"
                        Lastrowa = Lastrowa + 1
                            Rows(i).Copy Sheets(2).Rows(Lastrowa)
                End Select
            End With
    Next
Application.ScreenUpdating = True
End Sub

 

[vcoolio]

Hello Fireslguk,

Here's another option. You could move all the names into an array then filter on the array:-

Sub MoveIt()

Dim ar As Variant
ar = Sheet3.Range("A2", Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp))

Application.ScreenUpdating = False

For i = 1 To UBound(ar)
    With Sheet1.[A1].CurrentRegion
        .AutoFilter 3, ar(i, 1)
        .Offset(1).EntireRow.Copy Sheet2.Range("A" & Rows.Count).End(3)(2)
        .AutoFilter
    End With
Next i

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub

You'll only have to list all the names into Column A of Sheet3 starting in row2. You can add/delete names to/from the list as required.

I hope that this helps.

Cheerio,
vcoolio.

 

[My Aswer Is This]

If you want to use a filter which may be a little faster try this:
Run this script from Sheet(1)

Sub Filter_Me_With_Array()
'Modified  8/7/2018  8:38:28 AM  EDT
Application.ScreenUpdating = False
Dim Lastrow As Long
Dim Lastrowa As Long
Dim c As Long
Dim Counter As Long
c = 3 ' Column Number Modify this to your need
Lastrow = Cells(Rows.Count, c).End(xlUp).Row
Lastrowa = Sheets(2).Cells(Rows.Count, c).End(xlUp).Row + 1
With Sheets(1).Cells(1, c).Resize(Lastrow)
    .AutoFilter 1, Criteria1:=Array("Matthew", "Green", "Ali", "Pop", "Go", "One", "Red", "Fox"), Operator:=xlFilterValues
    Counter = .Columns(c).SpecialCells(xlCellTypeVisible).Count
    If Counter > 1 Then
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).EntireRow.Copy Sheets(2).Cells(Lastrowa, 1)
    Else
        MsgBox "No values found"
    End If
    .AutoFilter
End With
Application.ScreenUpdating = True
End Sub