How to copy rows based on multiple email addresses? - excel

Question

I have a huge list of data and column 3 contains email addresses.
I'm trying to copy rows based on a mailing list. As long as the row contains one of the email addresses in the mailing list it should be copied to a new sheet.
I have code to copy data based on one email at a time.
I have a userform set up for several email addresses, but this is not efficient.
Here is my code that uses one email address at a time.
Private Sub CommandButton1_Click()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 3).Value = "<#gmail.com>" Then
Worksheets("Sheet1").Rows(i).Copy
Worksheets("Sheet2").Activate
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet2").Activate
End If
Next
Application.CutCopyMode = False
End Sub
How to copy rows based on multiple emails addresses?

Answer 1

I would suggest using the Advanced Filter The destination range will get written in a single step. If you can minimize the number of times your code reads/writes to/from a worksheet, the faster it will run.
Sheet 1
Read the comments in the code as they will be important for modifying it to your real data.
In particular, if your column 3 list does not have the same format as what you have shown in your code, you will need to modify the Criteria range to account for that. The Advanced Filter can also accept wild-cards in the criteria, so this might be another possible approach if your column 3 contains actual email addresses.
Option Explicit
Sub copyWithEmail()
Dim wsSrc As Worksheet, wsDest As Worksheet
Dim rSrc As Range, rDest As Range, rCrit As Range
Dim arrCrit As Variant
Dim I As Long
Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")
With wsDest
.Cells.Clear 'optional
Set rCrit = .Cells(1, 250) 'someplace off the screen view
Set rDest = .Cells(1, 1)
End With
'assumes original data starts in A1
'assumes first row is a header row
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion
'can get list of desired emails from user form; range someplace in the workbook; or hard-coded as we have here
arrCrit = Array("gmail.com", "abc.com")
For I = 0 To UBound(arrCrit)
'creating formula that mimics what you show in your code above.
arrCrit(I) = "=" & """=<#" & arrCrit(I) & ">"""
Next I
'create criteria range
'header is same header as in Source Data column 3
Set rCrit = rCrit.Resize(2 + UBound(arrCrit))
rCrit(1) = rSrc(1, 3)
rCrit.Offset(1).Resize(rCrit.Rows.Count - 1) = WorksheetFunction.Transpose(arrCrit)
'Activate wsDest since we will be copying here
wsDest.Activate
rSrc.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=rCrit, CopyToRange:=rDest, Unique:=False
rDest.CurrentRegion.EntireColumn.AutoFit
rCrit.Clear 'get rid of this range
End Sub
Sheet 2

Answer 2

May be something like having Sheet3 of mialList and then
Private Sub CommandButton1_Click()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet, fnd As Range, cl As Range
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
Dim mailList As Range
x = Sh3.Range("A" & Sh3.Rows.Count).End(xlUp).Row
Set mailList = Sh3.Range("A2:A" & x)
'Assuming headers in row 1
For Each cl In mailList
b = Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row + 1
Set fnd = Sh1.Columns(3).Find(cl)
If Not fnd Is Nothing Then
Sh2.Rows(b).Value = Sh1.Rows(fnd.Row).Value
End If
Next
End Sub