Creating New Workbook from Sheet
in [Programming]
|
Prev: Large footnote
Next: Updating Excel QueryTable using VB
From: Ron de Bruin on 19 Jan 2010 16:19 Hi Ozzie Delete the two lines in the macro i posted 'Do stuff on the second sheet SecondSh.Range("A1").Value = "place code here to do what you want" Then after the do the paste part I add my code (the pivot must use that data so we must paste the data first) I not add all your code, but test this first to see if it is working See that I not hardcode the ranges in this example 'Copy/paste the visible data to the new workbook My_Range.SpecialCells(xlCellTypeVisible).Copy With WSNew.Range("A1") ' Paste:=8 will copy the columnwidth in Excel 2000 and higher ' Remove this line if you use Excel 97 .PasteSpecial Paste:=8 .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False .Select End With 'Do stuff on the second sheet SecondSh.Select ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ WSNew.UsedRange, Version:=xlPivotTableVersion10).CreatePivotTable _ TableDestination:=SecondSh.Range("A1"), TableName:="PivotTable3", DefaultVersion _ :=xlPivotTableVersion10 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozzie via OfficeKB.com" <u18021(a)uwe> wrote in message news:a25bff213377a(a)uwe... > Ron de Bruin wrote: >>Ok try this changed macro from the example workbook that add a extra sheet >> >>Where it say >> >> 'Do stuff on the second sheet >> SecondSh.Range("A1").Value = "place code here to do what you want" >> >>Add code to do what you want on that sheet >> >>The best thing is to record a macro when you do the steps manual. >>Then you have the basic code that you can add to the macro >> >>Sub Copy_To_Workbooks() > > > Ron, > > I have created the additional code to place on the 'second sheet' however it > keeps failing and I can't see why, any ideas? > > 'Do stuff on the second sheet > 'SecondSh.Range("A1").Value > Sheets("MySecondSheet").Select > Range("A1").Select > ActiveSheet.PivotCaches.Add(SourceType:=xlDatabase, > SourceData:= _ > "sheet1!R1C1:R405C8").CreatePivotTable TableDestination:= _ > "'[Cleaning - Repair.xls]MySecondSheet'!R6C2", TableName: > ="PivotTable3", _ > DefaultVersion:=xlPivotTableVersion10 > ActiveSheet.PivotTables("PivotTable3").AddFields RowFields: > ="Material", _ > ColumnFields:="Scanner Move" > With ActiveSheet.PivotTables("PivotTable3").PivotFields("PUK") > .Orientation = xlDataField > .Caption = "Count of PUK" > .Function = xlCount > .NumberFormat = "#,##0" > End With > Range("B2").Select > ActiveCell.FormulaR1C1 = "Report Heading" > Range("A6").Select > ActiveWindow.FreezePanes = True > > >>'Note: This macro use the function LastRow >> Dim My_Range As Range >> Dim FieldNum As Long >> Dim FileExtStr As String >> Dim FileFormatNum As Long >> Dim CalcMode As Long >> Dim ViewMode As Long >> Dim ws2 As Worksheet >> Dim MyPath As String >> Dim foldername As String >> Dim Lrow As Long >> Dim cell As Range >> Dim CCount As Long >> Dim WSNew As Worksheet >> Dim ErrNum As Long >> Dim SecondSh As Worksheet >> >> 'Set filter range on ActiveSheet: A11 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. >> 'You can also add the sheet name to the code like this : >> 'Worksheets("Sheet1").Range("A11:D" & LastRow(Worksheets("Sheet1"))) >> 'No need that the sheet is active then when you run the macro when you use this. >> Set My_Range = Range("A11:D" & LastRow(ActiveSheet)) >> My_Range.Parent.Select >> >> If ActiveWorkbook.ProtectStructure = True Or _ >> My_Range.Parent.ProtectContents = True Then >> MsgBox "Sorry, not working when the workbook or worksheet is protected", _ >> vbOKOnly, "Copy to new workbook" >> Exit Sub >> End If >> >> 'This example filters on the first column 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 >> >> 'Turn off AutoFilter >> My_Range.Parent.AutoFilterMode = False >> >> 'Set the file extension/format >> If Val(Application.Version) < 12 Then >> 'You use Excel 97-2003 >> FileExtStr = ".xls": FileFormatNum = -4143 >> Else >> 'You use Excel 2007 >> If ActiveWorkbook.FileFormat = 56 Then >> FileExtStr = ".xls": FileFormatNum = 56 >> Else >> FileExtStr = ".xlsx": FileFormatNum = 51 >> End If >> End If >> >> 'Change ScreenUpdating, Calculation, EnableEvents, .... >> With Application >> CalcMode = .Calculation >> .Calculation = xlCalculationManual >> .ScreenUpdating = False >> .EnableEvents = False >> End With >> ViewMode = ActiveWindow.View >> ActiveWindow.View = xlNormalView >> ActiveSheet.DisplayPageBreaks = False >> >> 'Delete the sheet RDBLogSheet if it exists >> On Error Resume Next >> Application.DisplayAlerts = False >> Sheets("RDBLogSheet").Delete >> Application.DisplayAlerts = True >> On Error GoTo 0 >> >> ' Add worksheet to copy/Paste the unique list >> Set ws2 = Worksheets.Add(After:=Sheets(Sheets.Count)) >> ws2.Name = "RDBLogSheet" >> >> '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 >> My_Range.Columns(FieldNum).AdvancedFilter _ >> Action:=xlFilterCopy, _ >> CopyToRange:=.Range("A3"), 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("A4:A" & Lrow) >> >> 'Filter the range >> My_Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _ >> Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?") >> >> 'Check if there are no more then 8192 areas(limit of areas) >> CCount = 0 >> On Error Resume Next >> CCount = My_Range.Columns(1).SpecialCells(xlCellTypeVisible) _ >> .Areas(1).Cells.Count >> On Error GoTo 0 >> If CCount = 0 Then >> MsgBox "There are more than 8192 areas for the value : " & cell.Value _ >> & vbNewLine & "It is not possible to copy the visible data." _ >> & vbNewLine & "Tip: Sort your data before you use this macro.", _ >> vbOKOnly, "Split in worksheets" >> Else >> 'Add new workbook with one sheet >> Set WSNew = Workbooks.Add(xlWBATWorksheet).Worksheets(1) >> Set SecondSh = Worksheets.Add >> SecondSh.Name = "MySecondSheet" >> WSNew.Activate >> >> 'Do stuff on the second sheet >> SecondSh.Range("A1").Value = "place code here to do what you want" >> >> 'Copy/paste the visible data to the new workbook >> My_Range.SpecialCells(xlCellTypeVisible).Copy >> With WSNew.Range("A1") >> ' Paste:=8 will copy the columnwidth in Excel 2000 and higher >> ' Remove this line if you use Excel 97 >> .PasteSpecial Paste:=8 >> .PasteSpecial xlPasteValues >> .PasteSpecial xlPasteFormats >> Application.CutCopyMode = False >> .Select >> End With >> >> 'Save the file in the new folder and close it >> On Error Resume Next >> WSNew.Parent.SaveAs foldername & _ >> cell.Value & FileExtStr, FileFormatNum >> If Err.Number > 0 Then >> Err.Clear >> ErrNum = ErrNum + 1 >> >> WSNew.Parent.SaveAs foldername & _ >> "Error_" & Format(ErrNum, "0000") & FileExtStr, FileFormatNum >> >> .Cells(cell.Row, "B").Formula = "=Hyperlink(""" & foldername & _ >> "Error_" & Format(ErrNum, "0000") & FileExtStr & """)" >> >> .Cells(cell.Row, "A").Interior.Color = vbRed >> Else >> .Cells(cell.Row, "B").Formula = _ >> "=Hyperlink(""" & foldername & cell.Value & FileExtStr & """)" >> End If >> >> WSNew.Parent.Close False >> On Error GoTo 0 >> End If >> >> 'Show all the data in the range >> My_Range.AutoFilter Field:=FieldNum >> >> Next cell >> .Cells(1, "A").Value = "Red cell: can't use the Unique name as file name" >> .Cells(1, "B").Value = "Created Files (Click on the link to open a file)" >> .Cells(3, "A").Value = "Unique Values" >> .Cells(3, "B").Value = "Full Path and File name" >> .Cells(3, "A").Font.Bold = True >> .Cells(3, "B").Font.Bold = True >> .Columns("A:B").AutoFit >> >> End With >> >> 'Turn off AutoFilter >> My_Range.Parent.AutoFilterMode = False >> >> If ErrNum > 0 Then >> MsgBox "Rename every WorkSheet name that start with ""Error_"" manually" _ >> & vbNewLine & "There are characters in the name that are not allowed" _ >> & vbNewLine & "in a sheet name or the worksheet already exist." >> End If >> >> 'Restore ScreenUpdating, Calculation, EnableEvents, .... >> My_Range.Parent.Select >> ActiveWindow.View = ViewMode >> ws2.Select >> With Application >> .ScreenUpdating = True >> .EnableEvents = True >> .Calculation = CalcMode >> End With >> >>End Sub >> >>> Hi Ozzie >>> >>[quoted text clipped - 17 lines] >>>> >>>> Many thanks > > -- > Message posted via OfficeKB.com > http://www.officekb.com/Uwe/Forums.aspx/excel-programming/201001/1 >
From: Ozzie via OfficeKB.com on 19 Jan 2010 16:43 Ron de Bruin wrote: >Hi Ozzie > >Delete the two lines in the macro i posted > > 'Do stuff on the second sheet > SecondSh.Range("A1").Value = "place code here to do what you want" > >Then after the do the paste part I add my code (the pivot must use that data so we must paste the data first) >I not add all your code, but test this first to see if it is working >See that I not hardcode the ranges in this example > > 'Copy/paste the visible data to the new workbook > My_Range.SpecialCells(xlCellTypeVisible).Copy > With WSNew.Range("A1") > ' Paste:=8 will copy the columnwidth in Excel 2000 and higher > ' Remove this line if you use Excel 97 > .PasteSpecial Paste:=8 > .PasteSpecial xlPasteValues > .PasteSpecial xlPasteFormats > Application.CutCopyMode = False > .Select > End With > > 'Do stuff on the second sheet > SecondSh.Select > ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ > WSNew.UsedRange, Version:=xlPivotTableVersion10).CreatePivotTable _ > TableDestination:=SecondSh.Range("A1"), TableName:="PivotTable3", DefaultVersion _ > :=xlPivotTableVersion10 > >>>Ok try this changed macro from the example workbook that add a extra sheet >>> >[quoted text clipped - 237 lines] >>>>> >>>>> Many thanks Ron, Yes the code, copy, works fine but fails when it gets to the following; ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ WSNew.UsedRange, Version:=xlPivotTableVersion10). CreatePivotTable _ TableDestination:=SecondSh.Range("A1"), TableName: ="PivotTable3", DefaultVersion _ :=xlPivotTableVersion10 it just doesn't like the creating of the pivot -- Message posted via http://www.officekb.com
From: Ron de Bruin on 19 Jan 2010 17:19 This is working in 2003 ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ WSNew.UsedRange).CreatePivotTable TableDestination:= _ SecondSh.Range("A1"), TableName:="PivotTable2", DefaultVersion:= _ xlPivotTableVersion10 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozzie via OfficeKB.com" <u18021(a)uwe> wrote in message news:a25caaaf8be3d(a)uwe... > Ron de Bruin wrote: >>Hi Ozzie >> >>Delete the two lines in the macro i posted >> >> 'Do stuff on the second sheet >> SecondSh.Range("A1").Value = "place code here to do what you want" >> >>Then after the do the paste part I add my code (the pivot must use that data so we must paste the data first) >>I not add all your code, but test this first to see if it is working >>See that I not hardcode the ranges in this example >> >> 'Copy/paste the visible data to the new workbook >> My_Range.SpecialCells(xlCellTypeVisible).Copy >> With WSNew.Range("A1") >> ' Paste:=8 will copy the columnwidth in Excel 2000 and higher >> ' Remove this line if you use Excel 97 >> .PasteSpecial Paste:=8 >> .PasteSpecial xlPasteValues >> .PasteSpecial xlPasteFormats >> Application.CutCopyMode = False >> .Select >> End With >> >> 'Do stuff on the second sheet >> SecondSh.Select >> ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _ >> WSNew.UsedRange, Version:=xlPivotTableVersion10).CreatePivotTable _ >> TableDestination:=SecondSh.Range("A1"), TableName:="PivotTable3", DefaultVersion >> _ >> >> :=xlPivotTableVersion10 >> >>>>Ok try this changed macro from the example workbook that add a extra sheet >>>> >>[quoted text clipped - 237 lines] >>>>>> >>>>>> Many thanks > > Ron, > > Yes the code, copy, works fine but fails when it gets to the following; > > ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, > SourceData:= _ > WSNew.UsedRange, Version:=xlPivotTableVersion10). > CreatePivotTable _ > TableDestination:=SecondSh.Range("A1"), TableName: > ="PivotTable3", DefaultVersion _ > :=xlPivotTableVersion10 > > it just doesn't like the creating of the pivot > > -- > Message posted via http://www.officekb.com >
From: Ozzie via OfficeKB.com on 19 Jan 2010 17:37 Ron de Bruin wrote: >This is working in 2003 > > ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ > WSNew.UsedRange).CreatePivotTable TableDestination:= _ > SecondSh.Range("A1"), TableName:="PivotTable2", DefaultVersion:= _ > xlPivotTableVersion10 > >>>Hi Ozzie >>> >[quoted text clipped - 47 lines] >> >> it just doesn't like the creating of the pivot Ron, Thank you very much, it all works very, very well, really appreciated -- Message posted via http://www.officekb.com
From: Ron de Bruin on 19 Jan 2010 17:43
You are welcome Seems the recorder in 2007 is not working correct Time that I play more with this stuff (if I have time) -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ozzie via OfficeKB.com" <u18021(a)uwe> wrote in message news:a25d2285da8ed(a)uwe... > Ron de Bruin wrote: >>This is working in 2003 >> >> ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _ >> WSNew.UsedRange).CreatePivotTable TableDestination:= _ >> SecondSh.Range("A1"), TableName:="PivotTable2", DefaultVersion:= _ >> xlPivotTableVersion10 >> >>>>Hi Ozzie >>>> >>[quoted text clipped - 47 lines] >>> >>> it just doesn't like the creating of the pivot > > > Ron, Thank you very much, it all works very, very well, really appreciated > > -- > Message posted via http://www.officekb.com > |