Hi all,
I've changed jobs and gone back in time. Current place does not have any systems in place at all, uses Excel 2007 and has frankly baffling processses in place for even the most straightforward tasks. It's driving me crackers but that's an aside.
I have a single dataset from which I derive a number of reports to send out to clients as invoices with backing data to support. Each of these is a single, separate workbooks with several worksheets. One of these worksheets is a pivot table and it's causing me a great many problems. I have fathomed out how to create and get the fields and dat I need I just cannot for the life of me work out how to clear the pivotcache and use the data from the current workbook. I have looked up on a great many sites to try to find the solution and have ended up going backwards and forwards as they reference each other and none of them are helping me. Therefore, at my wits end, I have come to Ozgrid. Any help greatly appreciated.
Current code below:
Sub SplitDataToUniqueWorkBook()
'Author: Kieran McHugh
'Date: 27/08/2014
'Summary: Produce list of unique CCG codes
' Filter on each value. Copy and paste into template worksheet
' Save as new workbook called by the CCG Code
'
'Further work: ONGOING
'Known issues:
'NOTES:
'Declare variables
Dim rCl As Range, rRng As Range
Dim fName As String, SvPath As String
Dim FrzMth As Integer, FlxMth As Integer
Dim LR As Long
Dim PvtTbl As PivotTable
Dim wsData As Worksheet
Dim rngData As Range
Dim PvtTblCache As PivotCache
Dim wsPvtTbl As Worksheet
Dim pvtFld As PivotField
Dim pc As PivotCache
'
MsgBox "Please select a folder to save the completed files"
Application.FileDialog(msoFileDialogFolderPicker).Show
SvPath = CurDir & "\"
FrzMth = InputBox("Enter the current freeze month", "Freeze month entry")
FlxMth = InputBox("Enter the current flex month", "Flex month entry")
With Sheets("Invoices")
.Range("D1").Value = FrzMth
End With
With Sheets("SLA Data")
.Range("AX1").EntireColumn.Delete
.Range("A1").CurrentRegion.Columns(46).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheet1.Range( _
"AX1"), Unique:=True
Set rRng = .Range(.Cells(2, 50), .Cells(.Rows.Count, 50).End(xlUp))
End With
For Each rCl In rRng
fName = rCl.Value
Sheets("PLD").Range("A1").CurrentRegion.Clear
With Sheets("Invoices")
.Range("A1").Value = rCl
End With
With Sheets("SLA Data")
.Range("AV2").Value = rCl.Value
.Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("AV1:AV2"), CopyToRange:=Sheets("PLD").Range("A3"), Unique:=False
End With
ThisWorkbook.Sheets(Array("Invoices", "PLD", "CCG Validation Query")).Copy
With Sheets("PLD")
Range("A3").CurrentRegion.RowHeight = "11.25"
End With
With Sheets("PLD")
Rows(1).RowHeight = 11.25
Rows(2).RowHeight = 11.25
Rows(3).WrapText = True
Rows(3).RowHeight = 22.5
End With
With Sheets("PLD")
.Columns(1).ColumnWidth = "5"
.Columns(2).ColumnWidth = "8"
.Columns(3).ColumnWidth = "8"
.Columns(4).ColumnWidth = "40"
.Columns(5).ColumnWidth = "14"
.Columns(6).ColumnWidth = "40"
.Columns(7).ColumnWidth = "8"
.Columns(8).ColumnWidth = "8"
.Columns(9).ColumnWidth = "8"
.Columns(10).ColumnWidth = "8"
.Columns(11).ColumnWidth = "20"
.Columns(12).ColumnWidth = "20"
.Columns(13).ColumnWidth = "1"
.Columns(14).ColumnWidth = "14"
.Columns(15).ColumnWidth = "14"
.Columns(16).ColumnWidth = "14"
.Columns(17).ColumnWidth = "14"
.Columns(18).ColumnWidth = "14"
.Columns(19).ColumnWidth = "14"
.Columns(20).ColumnWidth = "14"
.Columns(21).ColumnWidth = "14"
.Columns(22).ColumnWidth = "14"
.Columns(23).ColumnWidth = "14"
.Columns(24).ColumnWidth = "14"
.Columns(25).ColumnWidth = "14"
.Columns(26).ColumnWidth = "14"
.Columns(27).ColumnWidth = "14"
.Columns(28).ColumnWidth = "14"
.Columns(29).ColumnWidth = "14"
.Columns(30).ColumnWidth = "14"
.Columns(31).ColumnWidth = "14"
.Columns(32).ColumnWidth = "14"
.Columns(33).ColumnWidth = "14"
.Columns(34).ColumnWidth = "14"
.Columns(35).ColumnWidth = "14"
.Columns(36).ColumnWidth = "14"
.Columns(37).ColumnWidth = "12"
.Columns(38).ColumnWidth = "12"
.Columns(39).ColumnWidth = "12"
.Columns(40).ColumnWidth = "12"
.Columns(41).ColumnWidth = "12"
.Columns(42).ColumnWidth = "12"
.Columns(43).ColumnWidth = "12"
.Columns(44).ColumnWidth = "12"
.Columns(45).ColumnWidth = "12"
.Columns(46).ColumnWidth = "40"
.Columns(38).NumberFormat = "#,##0;[Red](#,##0)"
.Columns(39).NumberFormat = "$#,##0_);[Red]($#,##0)"
.Columns(40).NumberFormat = "#,##0;[Red](#,##0)"
.Columns(41).NumberFormat = "#,##0;[Red](#,##0)"
.Columns(42).NumberFormat = "#,##0;[Red](#,##0)"
.Columns(43).NumberFormat = "$#,##0_);[Red]($#,##0)"
.Columns(44).NumberFormat = "$#,##0_);[Red]($#,##0)"
.Columns(45).NumberFormat = "$#,##0_);[Red]($#,##0)"
End With
With Sheets("PLD")
Range("F4").Select
ActiveWindow.FreezePanes = True
End With
'With Sheets("PLD")
' .Range("A3:AT3").AutoFilter Field:=1, Criteria1:=FrzMth
'End With
'With Sheets("PLD")
'LR = Range("AM" & Rows.Count).End(xlUp).Row
'Range("AM1").Formula = "=SUBTOTAL(9,AM3:AM" & LR & ")"
'Range("AQ1").Formula = "=SUBTOTAL(9,AQ3:AQ" & LR & ")"
'Range("AR1").Formula = "=SUBTOTAL(9,AR3:AR" & LR & ")"
'Range("AS1").Formula = "=SUBTOTAL(9,AS3:AS" & LR & ")"
'End With
With Sheets("PLD")
.Rows(1).Font.Size = 8
End With
Worksheets.Add
ActiveSheet.Name = "Pivot"
For Each pc In ActiveWorkbook.PivotCaches
pc.MissingItemsLimit = xlMissingItemsNone
pc.Refresh
Next
Set wsData = Worksheets("PLD")
Set wsPvtTbl = Worksheets("Pivot")
Set rngData = wsData.Range("A3").CurrentRegion
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngData, _
Version:=xlPivotTableVersion12).CreatePivotTable TableDestination:=wsPvtTbl.Range("A1"), _
TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion12
Set PvtTbl = wsPvtTbl.PivotTables("PivotTable1")
PvtTbl.ManualUpdate = True
Set pvtFld = PvtTbl.PivotFields("Month")
pvtFld.Orientation = xlPageField
Set pvtFld = PvtTbl.PivotFields("POD Desc")
pvtFld.Orientation = xlRowField
With PvtTbl.PivotFields("Activity Plan This Month")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Position = 1
End With
With PvtTbl.PivotFields("Activity Actual This Month")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Position = 2
End With
With PvtTbl.PivotFields("Activity Diff Actual-Plan")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "#,##0"
.Position = 3
End With
With PvtTbl.PivotFields("Price Plan This Month")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
.Position = 4
End With
With PvtTbl.PivotFields("Price Actual This Month")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
.Position = 5
End With
With PvtTbl.PivotFields("Price Diff Actual-Plan This Month")
.Orientation = xlDataField
.Function = xlSum
.NumberFormat = "$#,##0"
.Position = 6
End With
With PvtTbl.PivotFields("Month").ClearAllFilters
PvtTbl.PivotFields("Month").CurrentPage = FrzMth
End With
PvtTbl.ManualUpdate = False
Worksheets("Pivot").PivotTables("PivotTable1").EnableFieldList = False
Worksheets("Pivot").PivotTables("PivotTable1").HasAutoFormat = False
With Sheets("Pivot")
.Columns(1).ColumnWidth = "40"
.Columns(2).ColumnWidth = "12"
.Columns(3).ColumnWidth = "12"
.Columns(4).ColumnWidth = "12"
.Columns(5).ColumnWidth = "12"
.Columns(6).ColumnWidth = "12"
.Columns(7).ColumnWidth = "12"
End With
With Sheets("Pivot")
.UsedRange.Font.Size = 8
.UsedRange.Font.Name = "Calibri"
.UsedRange.RowHeight = 11.25
.Range("A4:G4").HorizontalAlignment = xlCenter
End With
With Sheets("Pivot")
Rows(4).WrapText = True
Rows(4).RowHeight = 22.5
End With
'
'
'
'.Rows(1).RowHeight = "6"
'.Range("AD1").EntireColumn.Delete
'.AutoFilterMode = False
'.Range("I26:I28").HorizontalAlignment = xlRight
'.Range("I2").HorizontalAlignment = xlCenter
'.Range("I2").NumberFormat = "General"
'
'
'
'With Sheets("MEH PLD")
'Range("X28").Value = _
'Application.WorksheetFunction.Subtotal(9, .Range("X33", .Cells(.Rows.Count, "X")))
'End With
ActiveWorkbook.SaveAs SvPath & fName & " - North Middlesex University Hospital NHS Trust - M" & FlxMth & " Flex - M" & FrzMth & " Freeze.xlsx", _
FileFormat:=51, CreateBackup:=False
'NEW CODE MONTH 9 STARTS'
'
'Range("A1:I24").Select
'Selection.Copy
'Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
'Range("B32").Select
'Selection.End(xlDown).Select
'ActiveCell.Offset(1, -1).Select
'Range(Selection, Selection.End(xlToRight)).Select
'Range(Selection, Selection.End(xlDown)).Select
'Selection.Delete Shift:=xlUp
'Selection.ClearContents'
'
'
'NEW CODE MONTH 9 ENDS
ActiveWorkbook.Close True
' .DisplayAlerts = True
'End With
Next rCl
End Sub
Display More