First post so please bear with me. Ron's code has been a life saver! I need
to add three things to this gem.
Turn off display of msg when saving from xlsx to xls (loosing 2007
formatting is ok).
Prompt to specify name of sheets in new workbooks from "Sheet1" to "Charges".
Prompt for mm-yy suffix to append to file name...like ABC Company 11-08.

Any assistance is greatly appreciated. Thanks for your time.

from Ron de Bruin's tips page:
Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Integer

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:D" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 1

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add

With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Close AutoFilter
ws1.AutoFilterMode = False

Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

pasted wrong code....1st, correct code below (sorry)

"BeanCounterSue" wrote:

First post so please bear with me. Ron's code has been a life saver! I need
to add three things to this gem.
Turn off display of msg when saving from xlsx to xls (loosing 2007
formatting is ok).
Prompt to specify name of sheets in new workbooks from "Sheet1" to "Charges".
Prompt for mm-yy suffix to append to file name...like ABC Company 11-08.

Any assistance is greatly appreciated. Thanks for your time.

From Ron's tips page CORRECTED

Sub Copy_To_Workbooks()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim MyPath As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:D" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 1

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add

'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath

'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername

With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value & FileExtStr, FileFormatNum
WSNew.Parent.Close False

'Close AutoFilter
ws1.AutoFilterMode = False

Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

MsgBox "Look in " & foldername & " for the files"

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

To suppress the messages try this

Application.DisplayAlerts = FALSE 'Before the save and
Application.DisplayALerts = TRUE 'To turn it back on

For the next part, I'm assuming the sheet names are Sheet 1, Sheet 2, etc.

Sub test()
Dim Myname As String
Dim WS As Worksheet

Myname = InputBox("enter sheet name")
Debug.Print Myname

For Each WS In ThisWorkbook.Worksheets
WS.Name = Replace(WS.Name, "Sheet", Myname)

Next WS

End Sub


You'll need to have the WS defined as a worksheet somewhere in your code.

If you want to prompt for something try this

myName = InputBox("Enter Sheet Name")


--
HTH,
Barb Reinhardt

If this post was helpful to you, please click YES below.



"BeanCounterSue" wrote:

pasted wrong code....1st, correct code below (sorry)

"BeanCounterSue" wrote:

First post so please bear with me. Ron's code has been a life saver! I need
to add three things to this gem.
Turn off display of msg when saving from xlsx to xls (loosing 2007
formatting is ok).
Prompt to specify name of sheets in new workbooks from "Sheet1" to "Charges".
Prompt for mm-yy suffix to append to file name...like ABC Company 11-08.

Any assistance is greatly appreciated. Thanks for your time.

From Ron's tips page CORRECTED

Sub Copy_To_Workbooks()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim MyPath As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:D" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 1

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add

'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath

'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername

With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value & FileExtStr, FileFormatNum
WSNew.Parent.Close False

'Close AutoFilter
ws1.AutoFilterMode = False

Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

MsgBox "Look in " & foldername & " for the files"

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

Thanks for the quick response Barb!

I should have been more specific tho. I need to add to Ron's code but I
don't know exactly where and how. When I use this code (with my hard-coded
changes in it for file name, filter column, columns & rows), I run it from
ONE workbook with ONE sheet. It applies filters, etc then copies and pastes
the filtered data into about 30 new WorkBooks....all named with the Unique
name the filter was on, with all of Single sheets in the 30 new workbooks are
all named "Sheet1."

I'd like to have it prompt me for : a "suffix" to add to the end of the
WorkBook names (MM-YY), and prompt me for the correct name of the single
WorkSheet (like "Charges" or "Saved".) All workBooks would have the same
MM-YY suffix, and all the single sheets in those 30 workbooks would have the
same sheet name.

Thanks again,
Sue




"Barb Reinhardt" wrote:

To suppress the messages try this

Application.DisplayAlerts = FALSE 'Before the save and
Application.DisplayALerts = TRUE 'To turn it back on

For the next part, I'm assuming the sheet names are Sheet 1, Sheet 2, etc.

Sub test()
Dim Myname As String
Dim WS As Worksheet

Myname = InputBox("enter sheet name")
Debug.Print Myname

For Each WS In ThisWorkbook.Worksheets
WS.Name = Replace(WS.Name, "Sheet", Myname)

Next WS

End Sub


You'll need to have the WS defined as a worksheet somewhere in your code.

If you want to prompt for something try this

myName = InputBox("Enter Sheet Name")


--
HTH,
Barb Reinhardt

If this post was helpful to you, please click YES below.

Try this

Sub Copy_To_Workbooks()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim MyPath As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim ShName As String

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:D" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add

'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath

'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername

ShName = Application.InputBox("Fill in the name of the sheet", "Enter a sheet name")


With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
WSNew.Name = ShName

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the new worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value & " " & Format(Date, "MM-YY") & FileExtStr, FileFormatNum
WSNew.Parent.Close False

'Close AutoFilter
ws1.AutoFilterMode = False

Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

MsgBox "Look in " & foldername & " for the files"

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"BeanCounterSue" wrote in message
...
Thanks for the quick response Barb!

I should have been more specific tho. I need to add to Ron's code but I
don't know exactly where and how. When I use this code (with my hard-coded
changes in it for file name, filter column, columns & rows), I run it from
ONE workbook with ONE sheet. It applies filters, etc then copies and pastes
the filtered data into about 30 new WorkBooks....all named with the Unique
name the filter was on, with all of Single sheets in the 30 new workbooks are
all named "Sheet1."

I'd like to have it prompt me for : a "suffix" to add to the end of the
WorkBook names (MM-YY), and prompt me for the correct name of the single
WorkSheet (like "Charges" or "Saved".) All workBooks would have the same
MM-YY suffix, and all the single sheets in those 30 workbooks would have the
same sheet name.

Thanks again,
Sue




"Barb Reinhardt" wrote:

To suppress the messages try this

Application.DisplayAlerts = FALSE 'Before the save and
Application.DisplayALerts = TRUE 'To turn it back on

For the next part, I'm assuming the sheet names are Sheet 1, Sheet 2, etc.

Sub test()
Dim Myname As String
Dim WS As Worksheet

Myname = InputBox("enter sheet name")
Debug.Print Myname

For Each WS In ThisWorkbook.Worksheets
WS.Name = Replace(WS.Name, "Sheet", Myname)

Next WS

End Sub


You'll need to have the WS defined as a worksheet somewhere in your code.

If you want to prompt for something try this

myName = InputBox("Enter Sheet Name")


--
HTH,
Barb Reinhardt

If this post was helpful to you, please click YES below.

Hi Ron! I'm almost there. I must have messed up my paste of your code as I
was getting file names "Value = abc 11-08".xls so I switched it around to
'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & cell.Value & " " & _
Format(Date, "MM-YY") & FileExtStr, FileFormatNum

I now only need it to ASK me for the mm-yy to put in as it's never the
current month....it's usually the prior.

Thanks again
Sue



"Ron de Bruin" wrote:

Try this

Sub Copy_To_Workbooks()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim MyPath As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim ShName As String

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Determine the Excel version and file extension/format
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If ws1.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:D" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column B, ......
FieldNum = 1

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add worksheet to copy/Paste the unique list
Set ws2 = Worksheets.Add

'Fill in the path\folder where you want the new folder with the files
'you can use also this "C:\Users\Ron\test"
MyPath = Application.DefaultFilePath

'Add a slash at the end if the user forget it
If Right(MyPath, 1) < "\" Then
MyPath = MyPath & "\"
End If

'Create folder for the new files
foldername = MyPath & Format(Now, "yyyy-mm-dd hh-mm-ss") & "\"
MkDir foldername

ShName = Application.InputBox("Fill in the name of the sheet", "Enter a sheet name")


With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

'Add new workbook with one sheet
Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
WSNew.Name = ShName

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the new worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Save the file in the new folder and close it
WSNew.Parent.SaveAs foldername & " Value = " _
& cell.Value & " " & Format(Date, "MM-YY") & FileExtStr, FileFormatNum
WSNew.Parent.Close False

'Close AutoFilter
ws1.AutoFilterMode = False

Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

MsgBox "Look in " & foldername & " for the files"

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"BeanCounterSue" wrote in message
...
Thanks for the quick response Barb!

I should have been more specific tho. I need to add to Ron's code but I
don't know exactly where and how. When I use this code (with my hard-coded
changes in it for file name, filter column, columns & rows), I run it from
ONE workbook with ONE sheet. It applies filters, etc then copies and pastes
the filtered data into about 30 new WorkBooks....all named with the Unique
name the filter was on, with all of Single sheets in the 30 new workbooks are
all named "Sheet1."

I'd like to have it prompt me for : a "suffix" to add to the end of the
WorkBook names (MM-YY), and prompt me for the correct name of the single
WorkSheet (like "Charges" or "Saved".) All workBooks would have the same
MM-YY suffix, and all the single sheets in those 30 workbooks would have the
same sheet name.

Thanks again,
Sue




"Barb Reinhardt" wrote:

To suppress the messages try this

Application.DisplayAlerts = FALSE 'Before the save and
Application.DisplayALerts = TRUE 'To turn it back on

For the next part, I'm assuming the sheet names are Sheet 1, Sheet 2, etc.

Sub test()
Dim Myname As String
Dim WS As Worksheet

Myname = InputBox("enter sheet name")
Debug.Print Myname

For Each WS In ThisWorkbook.Worksheets
WS.Name = Replace(WS.Name, "Sheet", Myname)

Next WS

End Sub


You'll need to have the WS defined as a worksheet somewhere in your code.

If you want to prompt for something try this

myName = InputBox("Enter Sheet Name")


--
HTH,
Barb Reinhardt

If this post was helpful to you, please click YES below.

I think I've got it. added:

Dim Filesufx As String
then after shName imputbox line added
Filesufx = Application.InputBox("Fill in the file name suffix", "Enter the
MM-YY")
then modified the save as to:
WSNew.Parent.SaveAs foldername & cell.Value & " " & _
Filesufx & FileExtStr, FileFormatNum

Seems to work just fine. It really does help to cut and paste code then
have at it! Thanks so much Ron for all of your tips!

Sue



"BeanCounterSue" wrote:

First post so please bear with me. Ron's code has been a life saver! I need
to add three things to this gem.
Turn off display of msg when saving from xlsx to xls (loosing 2007
formatting is ok).
Prompt to specify name of sheets in new workbooks from "Sheet1" to "Charges".
Prompt for mm-yy suffix to append to file name...like ABC Company 11-08.

Any assistance is greatly appreciated. Thanks for your time.

from Ron de Bruin's tips page:
Sub Copy_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim FieldNum As Integer

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:D" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = 1

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add

With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a new sheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the new
worksheet
ws1.AutoFilter.Range.Copy
With WSNew.Range("A1")
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With

'Close AutoFilter
ws1.AutoFilterMode = False

Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub