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.
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