Get subtotal by two criteria programmatically
I used a pivot table and have posted the code below as an aid to future
searchers.
Sub SummariseFX()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim fxwb As Workbook
Dim fxws As Worksheet
Dim nws As Worksheet
Dim tws As Worksheet
Dim ptc As PivotCache
Dim pt As PivotTable
Dim ptr As Range
Dim lastrow As Long
Dim lastsummaryrow As Long
Dim fxwsname As String
Dim twsname As String
Dim nwsname As String
Dim ptrname As String
Dim j2 As String
Dim a1 As String
Set fxwb = ActiveWorkbook
Set fxws = ActiveSheet
fxwsname = ActiveSheet.Name
twsname = "temp"
nwsname = "Detail"
j2 = "J2"
a1 = "a1"
'clear any existing pivot table ranges
For Each pt In fxws.PivotTables
pt.TableRange2.Clear
Next pt
'define input area and create pivot cache
lastrow = fxws.Cells(65536, 1).End(xlUp).Row
Sheets(fxwsname).Select
Sheets.Add
Sheets("Sheet1").Name = twsname
'MsgBox (fxwsname)
Sheets(fxwsname).Select
Sheets.Add
Sheets("Sheet2").Name = nwsname
Set tws = Sheets(twsname)
'MsgBox (twsname)
Set nws = Sheets(nwsname)
Worksheets(fxwsname).Activate
'Check the values in PTR IMPORTANT
Set ptr = fxws.Cells(1, 1).Resize(lastrow, 6)
Set ptc = fxwb.PivotCaches.Add(xlDatabase, ptr.Address)
ptr.Select
Set pt = ptc.CreatePivotTable(tabledestination:=tws.Range(a 1),
tablename:="PivotTable1")
'pt.ManualUpdate = False
'Settle date and currency
pt.AddFields RowFields:=Array("Settle Currency", "Actual Settle Date")
With pt.PivotFields("Principal")
.Orientation = xlDataField
.NumberFormat = "#,##0.00"
End With
'turning subtotals on an off for rows
tws.PivotTables("PivotTable1").PivotFields("Actual Settle
Date").Subtotals(1) = True
tws.PivotTables("PivotTable1").PivotFields("Actual Settle
Date").Subtotals(1) = False
tws.PivotTables("PivotTable1").PivotFields("Settle
Currency").Subtotals(1) = True
tws.PivotTables("PivotTable1").PivotFields("Settle
Currency").Subtotals(1) = False
'no blank cells
'pt.NullString = "0"
pt.DisplayNullString = False
pt.ColumnGrand = False
pt.RowGrand = False
'Sheets(fxwsname).Add
'' Sheets(fxwsname).Select
'' Sheets.Add
' Sheets("Sheet1").Select
' Sheets("Sheet1").Name = twsname
' Sheets(fxwsname).Select
'use pivottable2 to get the values only
pt.TableRange2.Offset(1, 0).Copy
nws.Range(a1).PasteSpecial xlPasteValues
Sheets(twsname).Delete
Worksheets(nwsname).Activate
' Sheets(tws).Select
' ActiveWindow.SelectedSheets.Delete
Columns("B:B").Select
Selection.NumberFormat = "dd/mm/yy;@"
Columns("C:C").Select
Selection.NumberFormat = "#,##0.00"
Range("A1").Select
lastsummaryrow = nws.Cells(65536, 1).End(xlUp).Row
With nws.Range(a1).Resize(lastsummaryrow - 2, 1)
With .SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
End With
.Value = .Value
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveWorkbook.Save
ActiveWorkbook.Close
End Sub
|