PDA

View Full Version : Copy pivot data in every sheets and save as to a new file



slamet Harto
02-24-2012, 10:47 PM
Hi there

Please help me, I want to split all the data based on column criteria, and create a pivot table for all sheets. Afterwards, all sheets that containing pivot table will copy into sheet template.
When the pivot is copied, macro will save sheet template to a new file. (like incremental save as to new file)

here is what i've done so far
Option Explicit
Sub SplitData()
Dim wbNew As Workbook
Dim wsData As Worksheet
Dim wsCrit As Worksheet
Dim wsNew As Worksheet
Dim rngCrit As Range
Dim LastRow As Long
Dim FPath As String
FPath = ActiveSheet.Parent.Path & "\"

With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set wsData = Worksheets("Data Sample")

LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row

Set wsCrit = Sheets("Setting")
wsCrit.Visible = xlSheetVisible

wsData.Range("D1:D" & LastRow).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=wsCrit.Range("A1"), Unique:=True

Set rngCrit = wsCrit.Range("A2")
While rngCrit.Value <> ""
Set wsNew = Worksheets.Add

wsData.Range("A1:U" & LastRow).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngCrit.Offset(-1).Resize(2), CopyToRange:=wsNew.Range("A1"), Unique:=True

If wbNew Is Nothing Then
wsNew.Copy
Set wbNew = ActiveWorkbook
wbNew.Worksheets(wbNew.Worksheets.Count).Name = rngCrit
makepivot
Else
wsNew.Copy after:=wbNew.Worksheets(wbNew.Worksheets.Count)
wbNew.Worksheets(wbNew.Worksheets.Count).Name = rngCrit
makepivot

End If

Application.DisplayAlerts = False
wsNew.Delete
rngCrit.EntireRow.Delete
Set rngCrit = wsCrit.Range("A2")
Wend

Dim sh As Worksheet, end_row As Long, source As Range

end_row = ActiveSheet.Range("AA" & Rows.Count).End(xlUp).Row
With ActiveWorkbook

End With
wsCrit.Visible = xlSheetVeryHidden


With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With

Application.DisplayAlerts = True

End Sub

Sub makepivot()

With ActiveSheet
lstrw_sh1 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
Set Rng = ActiveSheet.Range("A1" & ":" & "U" & lstrw_sh1)
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=Rng) _
.CreatePivotTable TableDestination:=ActiveSheet.Range("AA13"), _
TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion10

ThisWorkbook.ShowPivotTableFieldList = True


With ActiveSheet.PivotTables("PivotTable1").PivotFields("cust")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("sEQ")
.Orientation = xlRowField
.Position = 2
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Name")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Header17")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Header12")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Header13")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Header14")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Header15")
.Orientation = xlPageField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Header10")
.Orientation = xlPageField
.Position = 1
End With
Columns("AC:AH").Select
Selection.EntireColumn.Hidden = True

With ActiveSheet
.PivotTables("PivotTable1").PivotFields("Name").Subtotals = _
Array(False, False, False, False, False, False, False, False, False, False, False, False)

.Cells(.Rows.Count, "AA").End(xlUp).Offset(0, 0).Select
Selection.Delete
End With
ThisWorkbook.ShowPivotTableFieldList = False
Application.CommandBars("PivotTable").Visible = False
End With
'Range("Z:AI").Select
End Sub

Appreciate your help.
Harto