View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
sean_f sean_f is offline
external usenet poster
 
Posts: 16
Default 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