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