VBA macro to create new workbook

Hi All,

Need your help with VBA:-

I am attaching a sample worksheet for reference(please note I cannot attach the actual workbook as it contains confidential data).

what I need is a macro which will save the data for each of the item from the pivot filter in a new workbook and save the workbook with the name selected from the filter.

Thank you for your help

Originally Posted by Avicric

Hi All,

Need your help with VBA:-

I am attaching a sample worksheet for reference(please note I cannot attach the actual workbook as it contains confidential data).

what I need is a macro which will save the data for each of the item from the pivot filter in a new workbook and save the workbook with the name selected from the filter.

Thank you for your help

Hi guys,

I have managed something as far I my basic knowledge with VBA....
hope someone out there can guide/help me further....

I am attaching an updated excel with the VBA code I could come up with.....
need help to get it working...
need to save each worksheet with the name in the pivot filter...

thanks in advance!!!

Originally Posted by maniacb

Maybe this will work for you

Sub pivotloop()
Dim pt As PivotTable
Dim pi As PivotItem
Dim path As String
Dim filename As String

path = "C:\Users\Mark\Desktop\New folder"
Set pt = ActiveSheet.PivotTables("PivotTable1")
For Each pi In pt.PageFields("State").PivotItems
    pt.PageFields("State").CurrentPage = pi.Name

    ActiveSheet.Range("A2:D" & ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row).Copy
    Workbooks.Add
    ActiveSheet.Cells(1, 1).PasteSpecial xlPasteValues
    filename = pi.Name 'ActiveSheet.Range("B2")
    ActiveSheet.Columns("A:A").NumberFormat = "m/d/yyyy"
    ActiveWorkbook.SaveAs filename:=path & "/" & filename & ".xls", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close

Next pi
End Sub

hello Maniacb.....
thanks a ton you just made my day

not exactly what I wanted but helped me figure it out, so I am glad....