Get subtotal by two criteria programmatically

[sean_f]

Hi all,
what would be the best way to get a subtotal by multiple criteria
programmatically in the following situation?

I have a table (see below) which contains currency, date and value
columns.

I need to sum the value by the criteria date and currency

Curr Date Value
AUD 04/03/2006 -19077135
AUD 04/03/2006 18841290
AUD 04/05/2006 2400000
AUD 04/05/2006 12351998
CAD 04/05/2006 -5995905
CAD 04/05/2006 -5846000
CAD 04/06/2006 -33142536
CAD 04/06/2006 33142536
CHF 04/03/2006 -216352698
CHF 04/03/2006 209201801
CHF 04/04/2006 -215217476
CHF 04/04/2006 -1132500


For example in the table above I need to get the sum of all aussie
dollar transactions on the 3rd of april, then the sum of all aussie
dollar transactions on the 5th of april.
I need to repeat this for the canadian and swiss currency transactions
given.
I have tried using individual loops for defined currencies, but I
wonder if there is a more legant solution,

Many Thanks

sean F

 

[Guest]

Consider using a Pivot Table.

 

[Bob Phillips]

Either

- use a pivot table

or

-create an additional column that concatenates the two fields
(=A2&TEXT(B2,"mm/dd/yyyy")) and subtotal breaking on that column.

--
HTH

Bob Phillips

(remove nothere from email address if mailing direct)

 

[sean_f]

That is actually a good solution.

What I've done is:
Create a pivot table based on the live area. In a new sheet.
Headings are defined etc.
Copy that pivot table to a 2nd new sheet.
Paste Special choosing Values only.
Run code based on:
http://www.contextures.com/xlDataEntry02.html
This code assigns values to the blank cells.

So thanks wouldn't have thought of a pivot table.

I was trying to do this using programmatic advanced filter.

Sean _ F

 

[sean_f]

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(a1),
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