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