LinkBack Thread Tools Search this Thread Display Modes
Prev Previous Post   Next Post Next
  #4   Report Post  
Posted to microsoft.public.excel.programming
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

 
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes

Posting Rules

Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On


Similar Threads
Thread Thread Starter Forum Replies Last Post
subtotal function using criteria dbroc Excel Worksheet Functions 5 January 10th 10 01:46 AM
Subtotal by 2 different criteria d7 Excel Worksheet Functions 1 February 18th 09 09:41 AM
How can I delete rows programmatically based on certain criteria? nt_artagnian[_2_] New Users to Excel 2 March 8th 07 03:56 AM
How can I delete rows programmatically based on certain criteria? nt_artagnian[_2_] Excel Worksheet Functions 1 March 7th 07 05:48 PM
Get subtotal by two criteria sean_f Excel Programming 2 April 18th 06 05:10 PM


All times are GMT +1. The time now is 12:39 PM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"