VBScript: Refresh Excel Pivot Table programatically
Last update: Version 2.0 (June-2013)
To improve the ease of maintenance, I have moved most of the VBA code from DTS to Excel Macro.
Moreover, the new VBA use more Excel function, such as End Mode to determine last row faster, and CurrentRegion which reduce the need to modify the code if the position template row, or number of columns involved changes.
Then it will become like this:
----------------------
Version 1.0 (Feb-2013)
Excel PivotTable is very powerful. Many users love the power but there is a major problem: How can I automatic refresh the PivotTable with the latest data.
There are many ways to dump data to Excel. Besides using data connectors, I use DTS job to dump data into Excel.
In my working environment, I wrote a little MS SQL DTS Job to automate the process. The major steps are highlighted below:
To improve the ease of maintenance, I have moved most of the VBA code from DTS to Excel Macro.
Moreover, the new VBA use more Excel function, such as End Mode to determine last row faster, and CurrentRegion which reduce the need to modify the code if the position template row, or number of columns involved changes.
Then it will become like this:
VBA in DTS:
'**********************************************************************
' Visual Basic ActiveX Script
'************************************************************************
Function Main()
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("\\server\MIS_Report\Template\MyReport.xls")
'objExcel.Visible = True ' For debug only
With objExcel
objExcel.Run "Refresh_Data" 'I have moved all functions into Refresh_Data() inside the Excel
.ActiveWorkbook.CheckCompatibility = False
.ActiveWorkBook.Save
.Quit
End With
set objExcel = Nothing ' Garbage cleaning
Main = DTSTaskExecResult_Success ' Return true after success
End Function
VBA in Excel:
Sub Refresh_Data()
'
' Refresh_Data Macro
'
Call RAW_Backend1
ActiveWorkbook.RefreshAll ' Refreh all Pivot Tables
Sheets("SLA").Select
Range("A1").Select
Sheets("Index").Select
Range("A1").Select
End Sub
Sub RAW_Backend1()
Sheets("RAW_Backend1").Select
' ---------------------------
' Define the Named range
' ---------------------------
lastRow = ActiveSheet.Cells(65536, 1).End(xlUp).Row ' Find lastRow bottom up, using End Mode + up arrow
ActiveSheet.Range("a" & lastRow).CurrentRegion.Select ' CurrentRegion is a builtin function to select contingious data area
firstCol = Selection.Column
firstRow = Selection.Row
lastCol = firstCol + Selection.Columns.Count - 1
lastRow = firstRow + Selection.Rows.Count - 1
templateRow = firstRow + 1
' MsgBox ("='" & ActiveSheet.Name & "'!R" & firstRow & "C1:R" & lastRow & "C" & lastCol)
ActiveWorkbook.Names("RAW_BACKEND1").RefersToR1C1 = _
"='" & ActiveSheet.Name & "'!R" & firstRow & "C1:R" & lastRow & "C" & lastCol
' -- Copy the formula from template row to all other data row. In this example, column K and L contains formula and need to populate the formula to all other newly added rows
'Range("K" & templateRow & ":L" & templateRow).Select 'Selection.Copy
'Range("K" & templateRow + 1 & ":L" & lastRow).Select
'ActiveSheet.Paste
'Application.CutCopyMode = False
' --Copy the text formating ---------------
Rows(templateRow & ":" & templateRow).Select
Selection.Copy
' Range(Selection, Selection.End(xlDown)).Select ' this row is to use End Mode to select
Rows(templateRow + 1 & ":" & lastRow).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' -----------------
' Delete the template row. The template row contains dummy data but correct text format
Range(templateRow & ":" & templateRow).Delete
Range("A" & firstRow).Select
End Sub
----------------------
Version 1.0 (Feb-2013)
Excel PivotTable is very powerful. Many users love the power but there is a major problem: How can I automatic refresh the PivotTable with the latest data.
There are many ways to dump data to Excel. Besides using data connectors, I use DTS job to dump data into Excel.
In my working environment, I wrote a little MS SQL DTS Job to automate the process. The major steps are highlighted below:
- Excel Preparation
- Create an empty Excel worksheet
- Use DTS to dump raw data to Excel file. Let's name the data range as DATA_RANGE.
(The below sample DTS will dump data into three worksheets of an Excel)
- Create a PivotTable, by using the data from DATA_RANGE.
(a dummy record shown above will provide the text format needed. I will use VBA later to copy and paste the text format to other rows) - The Excel will contains two worksheet: a raw data worksheet and a PivotTable worksheet. We can also have multiple raw data worksheet and PivotTables.
- We can customize all the fonts, column width and look and feel in this file.
- Delete all data in the raw tables.
- Save as the file as MyReport_template.xls
- DTS Job Step
- copy MyReport_template.xls MyReport.xls
- Create an Excel file connection to MyReport.xls
- Write necessary Data Transformation Task to dump data into Excel. A Data Transformation Task will copy required (filtered and partially aggregated) from my SQL database to a second worksheet.
- A VBScript in my DTS job to force the Excel to "redefine" the data range and force the PowerPivot to "Refresh"
- I have added some VBA to change the formatting of the Excel to enhance the looking of the Excel. Here's my VBA:
- I will rename my final myExcel.xls to other name to identify the generation date.
'**********************************************************************
' Visual Basic ActiveX Script
'************************************************************************
Function Main()
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("\\MyServer\MIS\Template\MONTHLY_RPT\Monthly_Report_ALL.xls")
'objExcel.Visible = True ' For debug only. If enabled, we will actually see the Excel GUI.
intRow = 0
'Wscript.Echo objExcel.Cells(intRow, 1).Value ' For Debug use only
'Wscript.Echo cstr(intRow) + ":" + cstr(intRow)
' objExcel.Cells(intRow, 1).Font.Size = 24
'AddTotal objExcel, "COMPLIMENT", 5 Define_Areas objExcel
With objExcel
' Insert the date
.Sheets("Homepage").Select
.Range("A2").Value = MonthName(Month(DateAdd("m",-1,Date)),True) & "-" & Year(DateAdd("m",-1,Date))
'Cstr(Date) ' Instead of using Cstr, using DatePart(), Month(), Year() and MonthName() function provides a more detail control of the string formatting
' Delete the dummy row which is for formatting
' I have multiple RAW data worksheet. The data has been dumped to Excel using DTS previously
.Sheets("RAW_DATA_1").Select
.Range("5:5").Delete
.Sheets("RAW_DATA_2").Select
.Range("5:5").Delete
' Find and Replace using VBA (or VBScript). Special handling for NULL date value
.Sheets("RAW_DATA_2").Select
.Range("M:N").Replace "1/1/1900", "completed"
' Add Formula to Excel
' Check if P6 is zero
.Range("O6").Value = "=IF(P6<>0,""Y"","""")"
.Range("P6").Value = "=MAX($B$3-MAX(M6,N6),0)"
' Prepare dummy columns to produce aging report at PivotTable
.Range("Q6").Value = "=LOOKUP(P6,{0,30,91,182,364},{""< 1 month"",""1 - 3 months"",""3 - 6 months"",""6 - 12 months"",""over 12 months""})"
Define_Areas objExcel
.ActiveWorkBook.Save
'objExcel.Save
.Quit
End With
set objExcel = Nothing ' Garbage cleaning
Main = DTSTaskExecResult_Success ' Return true after success
End Function
Sub Define_Areas(objExcel)
'
'
'ActiveWorkbook.Names("New_Table").Delete ' for backup only
With objExcel
' ----------------------------------------------------------'
' Re-define named range
' ----------------------------------------------------------'
' Define Inbound Listing Area
.Sheets("RAW_DATA_1").Select ' Activate RAW_DATA_1 worksheet
intRow = 10 ' Detect last row, starts from Row 10
Do Until .Cells(intRow,1).Value = ""
'Wscript.Echo "Subject Matter: " & .Cells(intRow, 1).Value
intRow = intRow + 1
Loop
intRow = intRow - 1 ' The last row is empty. We have to go back one row.
' Re-Define Enquiries Area
With .ActiveWorkbook.Names("DataRange1")
.Name = "DataRange1"
.RefersToR1C1 = "='RAW_DATA_1'!R1C1:R" & intRow &"C14"
End With
.Range("A2").Select
' ------------------------------
' Define Enquiries Area
.Sheets("RAW_DATA_2").Select ' Activate Enquiry worksheet
intRow = 10 ' Detect last row
Do Until .Cells(intRow,1).Value = ""
'Wscript.Echo "Subject Matter: " & .Cells(intRow, 1).Value
intRow = intRow + 1
Loop
intRow = intRow - 1 ' The last row is empty. We have to go back one row.
' Re-Define Enquiries Area
With .ActiveWorkbook.Names("DataRange2")
.Name = "DataRange2"
.RefersToR1C1 = "=RAW_DATA_2!R4C1:R" & intRow &"C9"
End With
.Range("A2").Select
' Delete the dummy row which is for formatting
.Sheets("RAW_DATA_2").Select
.Range("2:2").Delete
' Add formula to first cell of a column
' Add formula to first cell of a column
.Range("B2").Value = "=IF(A2<>A1,1,0)"
' Copy and paste the formula from the reference row
objExcel.Range("B2").Copy
cNewRange = "B3:B" & intRow
'Msgbox(cNewRange)
'Range("A:A").Select
'Selection.Cut
objExcel.Range(cNewRange).Select
objExcel.ActiveSheet.Paste
objExcel.Application.CutCopyMode =False
' By using copy and paste, the formula will be updated automatically.
.Range("A2").Select
With .ActiveWorkbook.Worksheets("Overdue").Names("Overdue_RAW") '.ActiveWorkbook.Names("Overdue_RAW")
.RefersTo = "=Overdue!$A$5:$Q$" & intRow
'.Name = "Overdue_RAW"
'.Comment = "Overdue"
'.RefersToR1C1 = "=Overdue!R6C1:R" & intRow & "C16"
End With
' Copy and paste the formula from the reference row
.Range("O6:Q6").Copy
cNewRange = "O7:Q" & intRow
.Range(cNewRange).Select
.ActiveSheet.Paste
.Application.CutCopyMode =False
.Range("6:6").Delete
'msgbox "cut and paste done"
'.Range("M:N").Replace "01/01/1900", "" ## Remark Temp until I find a solution
.Range("A2").Select
'----------------
' ----------------------------------------------------------'
' Refresh Pivot Table
' ----------------------------------------------------------'
.ActiveWorkbook.RefreshAll
' Update Column Width programatically
.Sheets("Pivot_Suggestions").Select
.Sheets("Pivot_Suggestions").Select
.Columns("C:F").Select
.Range("C2").Activate
.Selection.ColumnWidth = 19.63
' Go back to "Homepage" worksheet
.Sheets("Homepage").Select
End With
End Sub
' Not used --------------------------------------------------
Sub AddTotal(objExcel, sheetName,nInitRow)
intRow = nInitRow
With objExcel
.Sheets(sheetName).Select
Do Until .Cells(intRow,1).Value = ""
'Wscript.Echo "Subject Matter: " & .Cells(intRow, 1).Value
intRow = intRow + 1
Loop
If intRow = nInitRow Then
'.Range("A" & intRow ).Value = "(No Data for this month.)"
Else
.Range("A" & intRow ).Value = "TOTAL"
.Range("B" & intRow ).Value = "=SUM(" & "B" & nInitRow & ":" & "B" & intRow-1 & ")"
.Range("C" & intRow ).Value = "=SUM(" & "C" & nInitRow & ":" & "C" & intRow-1 & ")"
.Range("E" & intRow ).Value = "=SUM(" & "E" & nInitRow & ":" & "E" & intRow-1 & ")"
.Range("F" & intRow ).Value = "=SUM(" & "F" & nInitRow & ":" & "F" & intRow-1 & ")"
' xlEdgeTop
With .Range("A" & intRow &":" & "F" & intRow)
.Borders(8).Weight = -4138
' xlEdgeBottom
' .Borders(9).Weight = -4138
.Font.Bold = TRUE
End With
if sheetName = "ENQUIRY" Then
'Wscript.Echo "=C" & intRow & "/B" & intRow
'Msgbox("=C" & intRow & "/B" & intRow)
With .Range("D" & intRow )
.Value = "=C" & intRow & "/B" & intRow
.NumberFormat ="0.00%"
End With
.Range("G" & intRow ).Value = "=SUM(" & "G" & 5 & ":" & "G" & intRow-1 & ")"
End If
End If
End With
End Sub
Comments