Copy/Paste into new workbooks
 

Please help me?

I am working in excel 2003. I have a working pivot table with over 50
entries. I need this marco to run each entry in the pivot table to
produce the data and then copy and paste the 2 worksheets into a new
workbook for each entry in the pivot table.
I need to paste two worksheets into new workbooks so clients can not
make changes. So far I am able to create one workbook just like I want
but after that it stops. I know I am missing something (I am learning
vba by myself ) but I am not sure what. Can someone please help me?

Sheets("Pivot").Select
For Each itm In
ActiveSheet.PivotTables("PivotTable3").PivotFields ("Lessee").PivotItems

Next
Cells.Select
Selection.Copy
Workbooks.Add
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Windows("Test Template (Revised).xls").Activate
Sheets("PD").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book1").Activate
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Form1"
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Form2"
Sheets("Sheet3").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Sheets("Form1").Select
Range("B1").Select
Selection.Copy
Sheets("Form2").Select
Range("F6:H6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "(All)"

Copy/Paste into new workbooks
 

Probably something like this is what you want: (untested pseudo code)

Dim bk as Workbook, bk2 as Workbook
Dim sh as Worksheet
set bk2 = Workbooks("Test Template (Revised).xls")
Thisworkbook.Activate
set sh = Worksheets("Pivot")

For Each itm In _
sh.PivotTables("PivotTable3") _
.PivotFields("Lessee").PivotItems
s = Itm.Value
sh.PivotTables("PivotTable3").PageFields(1).Page = itm.Value
sh.Cells.Copy
Workbooks.Add
set bk = ActiveWorkbook

Activesheet.Cells.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Activesheet.Cells.PasteSpecial Paste:=xlPasteColumnWidths, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Activesheet.Cells.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
bk2.Sheets("PD").cells.copy bk.Sheets("sheet2").Cells
bk.Sheets("Sheet1").Name = "Form1"
bk.Sheets("Sheet2").Name = "Form2"
Application.DisplayAlerts = False
bk.Sheets("Sheet3").Delete
Application.DisplayAlerts = True
bk.Sheets("Form1").Range("B1").Copy _
bk.Sheets("Form2").Range("F6:H6")
Application.CutCopyMode = False
bk.SaveAs Thisworkbook.Path & "\" & s & ".xls"
bk.close SaveChanges:=False
ThisWorkbook.Activate
Next

--
Regards,
Tom Ogilvy


" wrote:

Please help me?

I am working in excel 2003. I have a working pivot table with over 50
entries. I need this marco to run each entry in the pivot table to
produce the data and then copy and paste the 2 worksheets into a new
workbook for each entry in the pivot table.
I need to paste two worksheets into new workbooks so clients can not
make changes. So far I am able to create one workbook just like I want
but after that it stops. I know I am missing something (I am learning
vba by myself ) but I am not sure what. Can someone please help me?

Sheets("Pivot").Select
For Each itm In
ActiveSheet.PivotTables("PivotTable3").PivotFields ("Lessee").PivotItems

Next
Cells.Select
Selection.Copy
Workbooks.Add
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteColumnWidths,
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Windows("Test Template (Revised).xls").Activate
Sheets("PD").Select
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows("Book1").Activate
Sheets("Sheet2").Select
Cells.Select
ActiveSheet.Paste
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Form1"
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "Form2"
Sheets("Sheet3").Select
Application.CutCopyMode = False
ActiveWindow.SelectedSheets.Delete
Sheets("Form1").Select
Range("B1").Select
Selection.Copy
Sheets("Form2").Select
Range("F6:H6").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "(All)"

Copy/Paste into new workbooks
 

Thank you for help. However, now I am recieving a problem and not sure
how to fix it. I get a Run Time Error 438 - Object doesn't support the
property or method on line that reads:
sh.PivotTables("PivotTable3").PageFields(1).Page = itm.Value
Can someone please help me?



Tom Ogilvy wrote:
Probably something like this is what you want: (untested pseudo code)

Dim bk as Workbook, bk2 as Workbook
Dim sh as Worksheet
set bk2 = Workbooks("Test Template (Revised).xls")
Thisworkbook.Activate
set sh = Worksheets("Pivot")

For Each itm In _
sh.PivotTables("PivotTable3") _
.PivotFields("Lessee").PivotItems
s = Itm.Value
sh.PivotTables("PivotTable3").PageFields(1).Page = itm.Value
sh.Cells.Copy
Workbooks.Add
set bk = ActiveWorkbook

Activesheet.Cells.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Activesheet.Cells.PasteSpecial Paste:=xlPasteColumnWidths, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Activesheet.Cells.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
bk2.Sheets("PD").cells.copy bk.Sheets("sheet2").Cells
bk.Sheets("Sheet1").Name = "Form1"
bk.Sheets("Sheet2").Name = "Form2"
Application.DisplayAlerts = False
bk.Sheets("Sheet3").Delete
Application.DisplayAlerts = True
bk.Sheets("Form1").Range("B1").Copy _
bk.Sheets("Form2").Range("F6:H6")
Application.CutCopyMode = False
bk.SaveAs Thisworkbook.Path & "\" & s & ".xls"
bk.close SaveChanges:=False
ThisWorkbook.Activate
Next

--
Regards,
Tom Ogilvy

Copy/Paste into new workbooks
 

I am just guessing that your pagefield is the the pivotfield you are looping
through, so the code for that would be

instead of:
sh.PivotTables("PivotTable3").PageFields(1).Page = itm.Value

probably should be:
sh.PivotTables("PivotTable3").PivotFields("Lessee" ).CurrentPage = itm.Value



When I say pseudo code, it means I just composed it in the email and didn't
necessarily get all the object structures/syntax correct. But I would
expect the above line to be correct if Lessee is the pagefield and you want
to loop through all the pivotitem values in that field.

--
Regards,
Tom Ogilvy

wrote in message
ups.com...
Thank you for help. However, now I am recieving a problem and not sure
how to fix it. I get a Run Time Error 438 - Object doesn't support the
property or method on line that reads:
sh.PivotTables("PivotTable3").PageFields(1).Page = itm.Value
Can someone please help me?



Tom Ogilvy wrote:
Probably something like this is what you want: (untested pseudo code)

Dim bk as Workbook, bk2 as Workbook
Dim sh as Worksheet
set bk2 = Workbooks("Test Template (Revised).xls")
Thisworkbook.Activate
set sh = Worksheets("Pivot")

For Each itm In _
sh.PivotTables("PivotTable3") _
.PivotFields("Lessee").PivotItems
s = Itm.Value
sh.PivotTables("PivotTable3").PageFields(1).Page = itm.Value
sh.Cells.Copy
Workbooks.Add
set bk = ActiveWorkbook

Activesheet.Cells.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Activesheet.Cells.PasteSpecial Paste:=xlPasteColumnWidths, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Activesheet.Cells.PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
bk2.Sheets("PD").cells.copy bk.Sheets("sheet2").Cells
bk.Sheets("Sheet1").Name = "Form1"
bk.Sheets("Sheet2").Name = "Form2"
Application.DisplayAlerts = False
bk.Sheets("Sheet3").Delete
Application.DisplayAlerts = True
bk.Sheets("Form1").Range("B1").Copy _
bk.Sheets("Form2").Range("F6:H6")
Application.CutCopyMode = False
bk.SaveAs Thisworkbook.Path & "\" & s & ".xls"
bk.close SaveChanges:=False
ThisWorkbook.Activate
Next

--
Regards,
Tom Ogilvy

Copy/Paste into new workbooks
 

Thank you so much for your help so far. However, I have another
question. In my script I would like to save my workbooks to a mapped
drive. I filled in the blanks for the save code and tried it out. It
goes up to the third entry saves it and by the fourth I get a error
message. Runtime error 1004 - MS Office Excel cannot access the file
"\\blah\blah\blah" There are several possible reasons. It gives four
options but the contiue button is grayed out. Can you help?

Dawn

Here is the sample code:

bk.Sheets("PD").Range("F6:H6")
Application.CutCopyMode = False
bk.SaveAs Filename:="\\syslea222\busserve\Credit Logs\Archer
Project\Master Customer List\" & Worksheets("PD").Range("F6").Value &
".xls"
bk.Close SaveChanges:=False
ThisWorkbook.Activate