Home |
Search |
Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to generate worksheets
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to generate worksheets
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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to generate worksheets
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 |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to generate worksheets
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Macro to generate worksheets
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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Use a List to Generate Worksheets | Excel Programming | |||
How do I generate a list of the tabs/worksheets from a workbook? | Excel Worksheet Functions | |||
How can I generate a list of the worksheets by name | Excel Discussion (Misc queries) | |||
get Pivot table to generate separate worksheets for each row? | Excel Worksheet Functions | |||
Compare worksheets and generate list of missing data? | Excel Worksheet Functions |