Home |
Search |
Today's Posts |
#4
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
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 |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
subtotal function using criteria | Excel Worksheet Functions | |||
Subtotal by 2 different criteria | Excel Worksheet Functions | |||
How can I delete rows programmatically based on certain criteria? | New Users to Excel | |||
How can I delete rows programmatically based on certain criteria? | Excel Worksheet Functions | |||
Get subtotal by two criteria | Excel Programming |