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:

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:

image
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:
  1. Excel Preparation
    1. Create an empty Excel worksheet
    2. 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)
      image
      image
      image
    3. Create a PivotTable, by using the data from DATA_RANGE.
      image

      image
      (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)
    4. The Excel will contains two worksheet: a raw data worksheet and a PivotTable worksheet.  We can also have multiple raw data worksheet and PivotTables.
    5. We can customize all the fonts, column width and look and feel in this file.
    6. Delete all data in the raw tables.
    7. Save as the file as MyReport_template.xls
  2. DTS Job Step
    1. copy MyReport_template.xls MyReport.xls
    2. Create an Excel file connection to MyReport.xls
      image
    3. 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.
      image
    4. A VBScript in my DTS job to force the Excel to "redefine" the data range and force the PowerPivot to "Refresh"
      image
    5. I have added some VBA to change the formatting of the Excel to enhance the looking of the Excel.  Here's my VBA:
    6. 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)  ' For Debug use only
    ' 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  ' To redefine the Named Range, call SubRoutine Define_Areas()
   
        .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
        .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  ' Ensure the cursor returns to first cell
        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
        .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

Popular Posts