I have the following macro set up to take data from a large worksheet, and
copy the data to a smaller worksheet "template". The first column of the
large worksheet is employee number; all rows with the same employee number
are copied to the template, then the template is resaved with the employee
number as the file name.

This macro generates these worksheets for all employees. I would like to
know if I can modify this code to generate individual worksheets, instead of
all at once. The macro would ask me for which ID # I want to copy the data,
and then it will follow the same steps towards the end.


Sub Create_Paysheet()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long

'Name of the sheet with your data
Set ws1 = Sheets("Extract") '<<< Change to worksheet name

'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:T" & 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

' Add worksheet to copy/Paste the unique list
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 workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

Set WBNew = Workbooks.Open("U:\crewpaysheets\april test 2.xls")

'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 WBNew.Sheets("Paysheet").Range("A3")
..Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
..PasteSpecial xlPasteValues
Application.CutCopyMode = False
..Select

End With

'Save the file in the new folder and close it
WBNew.SaveAs "U:\crewpaysheets\test\" & cell.Value & FileExtStr, FileFormatNum
Application.DisplayAlerts = False
WBNew.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

With Application
..ScreenUpdating = True
End With
End Sub

Hi Richzip,

Try the follwing adaptation of Ron de Bruin's
code:

'==========
Sub Create_Paysheet()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Res As VbMsgBoxResult

'Name of the sheet with your data
Set ws1 = Sheets("Extract") '<<< Change to worksheet name

'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:T" & 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

' Add worksheet to copy/Paste the unique list
' 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 workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

'\\ For each ID#, ask user if sheet is to be created
Res = MsgBox(Prompt:="Create sheet for ID# " _
& cell.Value, _
Buttons:=vbYesNo, _
Title:="Select ID#")

If Res Then
'\\ User wants a new sheet for this ID#, so:

Set WBNew = Workbooks.Open( _
"U:\crewpaysheets\april test 2.xls")

'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 WBNew.Sheets("Paysheet").Range("A3")
.Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000
' and higher
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Select
End With

'Save the file in the new folder and close it
WBNew.SaveAs "U:\crewpaysheets\test\" _
& cell.Value _
& FileExtStr, _
FileFormatNum
Application.DisplayAlerts = False
WBNew.Close False

'Close AutoFilter
ws1.AutoFilterMode = False
End If
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
End With
End Sub
'==========



---
Regards.
Norman


"richzip" wrote in message
...
I have the following macro set up to take data from a large worksheet, and
copy the data to a smaller worksheet "template". The first column of the
large worksheet is employee number; all rows with the same employee number
are copied to the template, then the template is resaved with the employee
number as the file name.

This macro generates these worksheets for all employees. I would like to
know if I can modify this code to generate individual worksheets, instead
of
all at once. The macro would ask me for which ID # I want to copy the
data,
and then it will follow the same steps towards the end.


Sub Create_Paysheet()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long

'Name of the sheet with your data
Set ws1 = Sheets("Extract") '<<< Change to worksheet name

'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:T" & 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

' Add worksheet to copy/Paste the unique list
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 workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

Set WBNew = Workbooks.Open("U:\crewpaysheets\april test 2.xls")

'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 WBNew.Sheets("Paysheet").Range("A3")
.Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Select

End With

'Save the file in the new folder and close it
WBNew.SaveAs "U:\crewpaysheets\test\" & cell.Value & FileExtStr,
FileFormatNum
Application.DisplayAlerts = False
WBNew.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

With Application
.ScreenUpdating = True
End With
End Sub

Hi Norman,

Thanks for the help. I get a "next without for" error when I try to run
this code.

Also, looking at the code, does it ask me a "yes or no" question for every
ID#? If so, that's not quite what I want. I want it to ask me for an ID #,
which I type in, and the code generates the sheet only for that ID#.

Thanks again!
Rich

"Norman Jones" wrote:

Hi Richzip,

Try the follwing adaptation of Ron de Bruin's
code:

'==========
Sub Create_Paysheet()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Res As VbMsgBoxResult

'Name of the sheet with your data
Set ws1 = Sheets("Extract") '<<< Change to worksheet name

'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:T" & 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

' Add worksheet to copy/Paste the unique list
' 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 workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

'\\ For each ID#, ask user if sheet is to be created
Res = MsgBox(Prompt:="Create sheet for ID# " _
& cell.Value, _
Buttons:=vbYesNo, _
Title:="Select ID#")

If Res Then
'\\ User wants a new sheet for this ID#, so:

Set WBNew = Workbooks.Open( _
"U:\crewpaysheets\april test 2.xls")

'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 WBNew.Sheets("Paysheet").Range("A3")
.Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000
' and higher
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Select
End With

'Save the file in the new folder and close it
WBNew.SaveAs "U:\crewpaysheets\test\" _
& cell.Value _
& FileExtStr, _
FileFormatNum
Application.DisplayAlerts = False
WBNew.Close False

'Close AutoFilter
ws1.AutoFilterMode = False
End If
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
End With
End Sub
'==========



---
Regards.
Norman


"richzip" wrote in message
...
I have the following macro set up to take data from a large worksheet, and
copy the data to a smaller worksheet "template". The first column of the
large worksheet is employee number; all rows with the same employee number
are copied to the template, then the template is resaved with the employee
number as the file name.

This macro generates these worksheets for all employees. I would like to
know if I can modify this code to generate individual worksheets, instead
of
all at once. The macro would ask me for which ID # I want to copy the
data,
and then it will follow the same steps towards the end.


Sub Create_Paysheet()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long

'Name of the sheet with your data
Set ws1 = Sheets("Extract") '<<< Change to worksheet name

'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:T" & 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

' Add worksheet to copy/Paste the unique list
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 workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

Set WBNew = Workbooks.Open("U:\crewpaysheets\april test 2.xls")

'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 WBNew.Sheets("Paysheet").Range("A3")
.Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Select

End With

'Save the file in the new folder and close it
WBNew.SaveAs "U:\crewpaysheets\test\" & cell.Value & FileExtStr,
FileFormatNum
Application.DisplayAlerts = False
WBNew.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

With Application
.ScreenUpdating = True
End With
End Sub

Try this

Sub Copy_With_AutoFilter1()
Dim WS As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim FieldNum As Integer
Dim FilterString

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

'Name of the worksheet with the data
Set WS = 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 = WS.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

'Firstly, remove the AutoFilter
WS.AutoFilterMode = False

'Delete the sheet MyFilterResult if it exists
On Error Resume Next
Application.DisplayAlerts = False
Sheets("MyFilterResult").Delete
Application.DisplayAlerts = True
On Error GoTo 0

FilterString = Application.InputBox(prompt:="Enter ID", Type:=1)

rng.AutoFilter Field:=1, Criteria1:="=" & FilterString

'Add a new worksheet to copy the filter results in
Set WSNew = Worksheets.Add
WSNew.Name = "MyFilterResult"

'Copy the visible data and use PasteSpecial to paste to the new worksheet
WS.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
WS.AutoFilterMode = False

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

End Sub




--

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


"richzip" wrote in message ...
I have the following macro set up to take data from a large worksheet, and
copy the data to a smaller worksheet "template". The first column of the
large worksheet is employee number; all rows with the same employee number
are copied to the template, then the template is resaved with the employee
number as the file name.

This macro generates these worksheets for all employees. I would like to
know if I can modify this code to generate individual worksheets, instead of
all at once. The macro would ask me for which ID # I want to copy the data,
and then it will follow the same steps towards the end.


Sub Create_Paysheet()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WBNew As Workbook
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim foldername As String
Dim FieldNum As Integer
Dim FileExtStr As String
Dim FileFormatNum As Long

'Name of the sheet with your data
Set ws1 = Sheets("Extract") '<<< Change to worksheet name

'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:T" & 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

' Add worksheet to copy/Paste the unique list
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 workbook
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

Set WBNew = Workbooks.Open("U:\crewpaysheets\april test 2.xls")

'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 WBNew.Sheets("Paysheet").Range("A3")
.Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Select

End With

'Save the file in the new folder and close it
WBNew.SaveAs "U:\crewpaysheets\test\" & cell.Value & FileExtStr, FileFormatNum
Application.DisplayAlerts = False
WBNew.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

With Application
.ScreenUpdating = True
End With
End Sub

Hi Rich,

=============
Thanks for the help. I get a "next without for" error when I try to run
this code.
=============

' Set ws2 = Worksheets.Add
'
' With ws2

Inadvertently the above lines were commented out;
my apologies!

=============
Also, looking at the code, does it ask me a "yes or no" question for every
ID#? If so, that's not quite what I want. I want it to ask me for an ID #,
which I type in, and the code generates the sheet only for that ID#.
=============

You are correct; that is how the code would
operate.

I note, however, that R on de Bruin, who
wrote the original code, has responded to you
in an adjacent post.



---
Regards.
Norman