Copy Rows to new sheet based if value in column E exist anywhere in Column A

[KCPrescott]

I have excel file with several hundred entries.
Sheet 1 contains the main list of all the Companies formatted by:
Column A=User ID#
Column B=Company

In Column E there is a list of selected companies noted by their ID#

User ID	Company	Country		Selected User ID
1	Company1	US		3
2	Company2	China		5
3	Company3	Canada		7
4	Company4	US		19
5	Company5	US		44
6	Company6	US		65

<tbody>
</tbody>

I need a macro that will search Column A for all variables in Column E and then copy that row to Sheet 2.

So from the sample above Sheet 2 would look like:

User Id	Company	Country		Selected User ID
3	Company3	Canada		7
5	Comany5	US		44

<tbody>
</tbody>

I tried to modify this code:

Sub copyrows()

Dim tfCol As Range, Cell As Object

Set tfCol = Range("A2:A500") 'Substitute with the range which includes your True/False values

For Each Cell In tfCol

If IsEmpty(Cell) Then
Exit Sub
End If

If Cell.Value = ("3") Then 'Substitute with the Selected User ID
Cell.EntireRow.Copy
Sheet2.Select 'Substitute with your sheet
ActiveSheet.Range("A65536").End(xlUp).Select
Selection.Offset(1, 0).Select
ActiveSheet.Paste
End If

Next

End Sub


However this only lets me put in one value at a time. Is there a way to have it automatically use all the values from a specific column or to enter all the values into the code at one time?

Like: If Cell.Value = ("Search Column E for all values") Then
(Replacing the text in red for actual code)

Or: If Cell.Value = ("3" "5" "7"..."65") Then
(Replacing the text in red for actual code)

It seems like it should be feasible but I am new to excel and how to go about using macros and formulas. Please help.

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Sheets("Sheet1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim ID As Range
    Dim foundID As Range
    For Each ID In Sheets("Sheet1").Range("A2:A" & LastRow)
        Set foundID = Sheets("Sheet1").Range("E:E").Find(ID, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundID Is Nothing Then
            ID.EntireRow.Copy Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        End If
    Next ID
    Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Try this:

Sub Copy_My_Rows()
Application.ScreenUpdating = False
Dim Arr() As Variant
Dim Lastrow As Long
Dim Lastrowa As Long
Lastrow = Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row
Lastrowa = Cells(Rows.Count, "E").End(xlUp).Row
Lastrowb = Sheets(2).Cells(Rows.Count, "A").End(xlUp).Row + 1

Arr = Range("E1:E" & Lastrowa)
Dim R As Long
Dim C As Long
Dim i As Long

    For i = 1 To Lastrow

    For R = 1 To UBound(Arr, 1)  ' First array dimension is rows.
        
        For C = 1 To UBound(Arr, 2) ' Second array dimension is columns.
            
            If Cells(i, 1).Value = Arr(R, C) Then
                Rows(i).Copy Destination:=Sheets(2).Rows(Lastrowb)
                Lastrowb = Lastrowb + 1
           
           End If
    Next C
Next R
Next
Application.ScreenUpdating = True
End Sub

 

[PCL]

Try

Option Explicit

Sub Treat()
Dim WkRg  As Range
Dim Rg  As Range
Dim Temp
   Set WkRg = Sheet1.Cells(Rows.Count, 1).End(3).Offset(1, 0)
   For Each Rg In Sheet1.UsedRange.Offset(1, 0).Columns(1).Cells
      Temp = Evaluate("NOT(ISERROR(MATCH(" & Rg.Value & ",Sheet1!E:E,0)))")
      If (Temp) Then Set WkRg = Union(WkRg, Rg)
   Next
   Sheet2.Cells.ClearContents
   WkRg.EntireRow.Copy Destination:=Sheet2.Cells(1, 1)
End Sub

 

[KCPrescott]

This worked perfectly!
Thanks

 

[mumps]

Glad I could help and thanks for the rep.

 

[My Aswer Is This]

Glad to see your question was answered.