Seprate Data with the help of VBA code

Hi All,

I have one data file which i want to save as per the email provideed in one colomn.
i record a macro to seprate it.
but values in the filter are fixed. I want macro to pick values by itself.
please help ...........
Below is the code.
Sub sepration()

Application.Goto Reference:="R1C31"
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$215699").AutoFilter Field:=31, Criteria1:= _
"123@abc.com"
Range("A1:AI215699").Select
Range("AE1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

ChDir "D:\Sushil\email"
ActiveWorkbook.SaveAs Filename:="D:\Sushil\email\123@abc.com.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
Sheets("Dump").Select

Application.Goto Reference:="R1C31"
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$215699").AutoFilter Field:=31, Criteria1:= _
"234@abc.com"
Range("A1:AI215699").Select
Range("AE1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

ChDir "D:\Sushil\email"
ActiveWorkbook.SaveAs Filename:="D:\Sushil\email\234@abc.com.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
Sheets("Dump").Select

Application.Goto Reference:="R1C31"
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$215699").AutoFilter Field:=31, Criteria1:= _
"345@abc.com"
Range("A1:AI215699").Select
Range("AE1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

ChDir "D:\Sushil\email"
ActiveWorkbook.SaveAs Filename:="D:\Sushil\email\345@abc.com.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
Sheets("Dump").Select

Application.Goto Reference:="R1C31"
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$215699").AutoFilter Field:=31, Criteria1:= _
"456@abc.com"
Range("A1:AI215699").Select
Range("AE1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

ChDir "D:\Sushil\email"
ActiveWorkbook.SaveAs Filename:="D:\Sushil\email\456@abc.com.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
Sheets("Dump").Select

Application.DisplayAlerts = True

Application.Goto Reference:="R1C31"
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$215699").AutoFilter Field:=31, Criteria1:= _
"567@abc.com"
Range("A1:AI215699").Select
Range("AE1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

ChDir "D:\Sushil\email"
ActiveWorkbook.SaveAs Filename:="D:\Sushil\email\567@abc.com.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
Sheets("Dump").Select

Application.Goto Reference:="R1C31"
Selection.AutoFilter
ActiveSheet.Range("$A$1:$AI$215699").AutoFilter Field:=31, Criteria1:= _
"678@abc.com"
Range("A1:AI215699").Select
Range("AE1").Activate
Selection.Copy
Workbooks.Add
ActiveSheet.Paste

ChDir "D:\Sushil\email"
ActiveWorkbook.SaveAs Filename:="D:\Sushil\email\678@abc.com.xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

ActiveWindow.Close
Sheets("Dump").Select

End Sub

its resolved already. Thanks

its resolved already.

Thanks for your help.

Nick's picture

take a step back... What are

take a step back...
What are you actually trying to achieve here ?

you have a list of email addresses... then what ?

feel free to edit your post and attach your file