logo

5 нояб. 2012 г.

BIP: VBA для создания Сводной таблицы Excel

Всем привет! Сегодня хочу рассказать о том, какие интересные возможности дает нам Excel шаблон для Oracle BI Publisher. А именно – различная пост-обработка отчетов в формате Excel с помощью VBA-кода.
В качестве примера я покажу как можно построить сводную таблицу в Excel-отчете средствами самого Excel. И аналогично – как можно построить диаграмму в Excel-отчете.
1. Создадим новую модель данных – excel_test_dm, которая будет в качестве источника данных использовать файл Sales.xml из набора demo-файлов BIPublisher 11g.


На всякий случай выкладываю этот файл.

Удостоверимся, что созданная модель возвращает требуемые данные.



2. Создадим новый отчет – excel_test_rep – на базе существующей модели данных – excel_test_dm.
Загрузим новый шаблон разметки для отчета.







Сам Excel-файл шаблона разметки доступен здесь.

3. Сохраним отчет и перейдем в режим его просмотра.


4. Вот такая симпатичная сводная таблица отобразится при открытии файла результата отчета.


Также на другом листе будет доступна и сводная диаграмма.



Причем и сводная таблица, и диаграмма созданы с помощью VBA-кода в момент открытия Excel-файла результата отчета.
BIPublisher же лишь заполнил один лист файла – Data. По данным которого были построены остальные листы отчета – Pivot Chart, Pivot Table.


Думаю, идея понятна. С помощью BIPublisher осуществляется выгрузка данных на один из листов (возможно, лист скрытый) результирующего файла.
Создается макрос на открытие книги (Workbook_Open), который и осуществляет вызов различных VBA-процедур по пост-обработке данных. И сам макрос Workbook_Open и весь VBA-код следует располагать в рамках модуля Workbook ("ЭтаКнига")



Ну и наконец, сам код, используемый в данном примере:
Option Explicit

Const Success = False
Const Failure = True

Const sPivotTableWorksheet = "Pivot Table"                               'Name for the PivotTable Worksheet
Const sPivotChartWorksheet = "Pivot Chart"                               'Name for the PivotChart Worksheet
Const sDataRange = "XDO_GROUP_?ROW?"                                     'Named range containing raw data
Const sDataWithCaptionRange = "XDO_RAW_DATA"                             'Named range containing raw data with captions
Const sTitle = "Продажи по регионам"                                     'PivotTable's title
Const sChartType = xlColumnStacked                                       'Chart type to create (Optional)

Function NameExists(sName As String) As Boolean
'   NameExists:     Determine if a name exists in a spreadsheet
'   Parameters:     sName - Name to be checked
'   Example:        If Not NameExists("Data") then Setup_Data("Data")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    NameExists = False     'Assume not found
   
    Dim objName As Object
   
    For Each objName In Names
        If objName.Name = sName Then
            NameExists = Right(Names(sName).Value, 5) <> "#REF!"
            Exit For
        End If
    Next
   
ErrHandler:  
    If Err.Number <> 0 Then MsgBox _
        "NameExists - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 

Function ShapeExists(sName As String) As Boolean
'   ShapeExists:    See if a Shape Exists
'   Parameters:     sName - Shape Name to be checked
'   Example:        If not ShapeExists("EasyButton") then _
'           Create_Easy_Button "easy", "Show_Prompt", 10, 8
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    ShapeExists = False     'Assume not found
   
    Dim objName As Object
   
    For Each objName In ActiveSheet.Shapes
        If objName.Name = sName Then
            ShapeExists = True
            Exit For
        End If
    Next

ErrHandler:  
    If Err.Number <> 0 Then MsgBox _
        "ShapeExists - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function

 
Function WorkSheetExists(sName As String) As Boolean
'   WorkSheetExists:See if a Worksheet Exists
'   Parameters:     sName - Worksheet Name to be checked
'   Example:        If not WorkSheetExists("Data") then Setup_Data("Data")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    WorkSheetExists = False     'Assume not found
   
    Dim objName As Object
   
    For Each objName In Worksheets
        If objName.Name = sName Then
            WorkSheetExists = True
            Exit For
        End If
    Next
   
ErrHandler:  
    If Err.Number <> 0 Then MsgBox _
        "WorkSheetExists - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 

Function PivotTableExists(sWorksheet As String, sName As String) As Boolean
'   PivotTableExists:See if a PivotTable Exists
'   Parameters:     sName - PivotTable Name to be checked
'   Example:        If not PivotTableExists("pvtHrs") then Setup_pvtHrs
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
   On Error GoTo ErrHandler
    PivotTableExists = False     'Assume not found
   
    Dim objName As Object
   
    For Each objName In Worksheets(sWorksheet).PivotTables
        If objName.Name = sName Then
            PivotTableExists = True
            Exit For
        End If
    Next
   
ErrHandler:   
    If Err.Number <> 0 Then MsgBox _
        "PivotTableExists - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function
 

Function ChartExists(sName As String) As Boolean   
'   ChartExists:    See if a Chart Exists
'   Parameters:     sName - Chart Name to be checked
'   Example:        If not ChartExists("chtHrs") then Setup_chtHrs
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming
    On Error GoTo ErrHandler
    ChartExists = False     'Assume not found

    Dim objName As Object
   
    For Each objName In Charts
        If objName.Name = sName Then
            ChartExists = True
            Exit For
        End If
    Next

ErrHandler:   
    If Err.Number <> 0 Then MsgBox _
        "ChartExists - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function


Function Settings(sMode As String) As Boolean
'   Settings:       Saves, sets, and restores current application settings
'   Parameters:     sMode - "Save", "Restore", "Clear", "Disable", "Debug"
'   Example:        bResult = Settings("Disable")
'     Date   Init Modification
'   01/01/01 CWH  Initial Programming Copyright 2009 Craig Hatmaker
    On Error GoTo ErrHandler
    Settings = Failure                  'Assume the worst
   
    Static Setting(999, 4) As Variant  'Limit to 1,000 settings, prevent loops
    Static iLevel As Integer

    Select Case UCase(Trim(sMode))
        Case Is = "SAVE"
            Setting(iLevel, 0) = ActiveSheet.Type
            Setting(iLevel, 1) = ActiveSheet.Name
            Setting(iLevel, 2) = Application.EnableEvents
            Setting(iLevel, 3) = Application.ScreenUpdating
            Setting(iLevel, 4) = Application.Calculation
            iLevel = iLevel + 1
       
        Case Is = "RESTORE"
            If iLevel > 0 Then
                iLevel = iLevel - 1
                If Setting(iLevel, 0) = -4167 Then
                    Worksheets(Setting(iLevel, 1)).Activate
                Else
                    Charts(Setting(iLevel, 1)).Activate
                End If
                Application.EnableEvents = Setting(iLevel, 2)
                Application.ScreenUpdating = Setting(iLevel, 3)
                Application.Calculation = Setting(iLevel, 4)
            End If
      
        Case Is = "CLEAR"
            iLevel = 0
            Application.EnableEvents = True
            Application.ScreenUpdating = True
            Application.Calculation = xlCalculationAutomatic
           
        Case Is = "DISABLE"
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
           
        Case Is = "DEBUG"
            Debug.Print iLevel, _
            Setting(iLevel, 0), _
            Setting(iLevel, 1), _
            Setting(iLevel, 2), _
            Setting(iLevel, 3), _
            Setting(iLevel, 4), _
   
    End Select

    Settings = Success           'Normal end - no errors

ErrHandler:   
    If Err.Number <> 0 Then MsgBox _
        "Settings - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    On Error GoTo 0
End Function


Function Setup_Pivot(sWorksheet As String, sDataRange As String, _
                     sTitle As String, sPageFields() As String, _
                     sRowFields() As String, sColumnFields() As String, _
                     sDataFields() As String, sSortFields() As String, _
                     sMaxFields() As String) As Boolean
'   Setup_Pivot:    Set up a Pivot Table Worksheet and Pivot Table
'   Parameters:
'       sWorkSheet      - The worksheet name where the Pivot Table will be placed
'                         and the Pivot Table name.
'       sDataRange      - The data range (raw data/database extract)
'       sTitle          - A Title to put above the pivot table
'       sRowFields(#)   - Column headers in the data range that will appear
'                         down the left of the pivot table
'       sColumnFields(#)- Column headers in the data range that will appear
'                         across the top of the pivot table
'       sDataFields(#,2)
'                   #,0 = Column headers (field name) in the data range that
'                         will be in the body of the pivot table
'                   #,1 = Operation to be performed on the data (sum,count,etc.)
'                   #,2 = Caption to use for the resulting data field
'       sSortFields(#,2)
'                   #,0 = Row or Column field to sort
'                   #,1 = Ascending or Descending order
'                   #,2 = Data field to use to sort by
'       MaxFields(#,2)
'                   #,0 = Row or Column field to restrict
'                   #,1 = Max Number of entries to display
'                   #,2 = Data field to restrict by
'   Example:
'       Setup_Pivot sWorkSheet, sDataRange, sTitle, _
'                   sPageFields(), sRowFields(), sColumnFields(), sDataFields(), _
'                   sSortFields(), sMaxFields()
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming Copyright 2009 Craig Hatmaker   
    On Error GoTo ErrHandler            '
    Setup_Pivot = Failure               'Assume the Worst
               
    Settings "Save"                     'Save current settings
    Settings "Disable"                  'Disable events, updating, calculations
   
'   Dim Statements
    Dim i As Integer
       
'   Check for the Pivot Table Worksheet and create it if it doesn't exist
    If Not WorkSheetExists(sWorksheet) Then
        Sheets.Add
        Sheets(ActiveSheet.Name).Name = sWorksheet
    Else
        Worksheets(sWorksheet).Activate
        Cells.Select
        Selection.Clear
    End If

    If PivotTableExists(sWorksheet, sWorksheet) Then
'       Just Refresh the Pivot Table if it already exists
        Worksheets(sWorksheet).PivotTables(sWorksheet).RefreshTable
    Else
'        Create the Pivot Table if it doesnt' exist
         ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
                                        SourceData:=sDataRange).CreatePivotTable _
                                        TableDestination:=Range("A4"), _
                                        TableName:=sWorksheet
         With ActiveSheet.PivotTables(sWorksheet)
            .SmallGrid = False
           
'           Add Pivot Table Page Field
            For i = 0 To UBound(sPageFields())
                If sPageFields(i) <= "" Then Exit For
                With .PivotFields(sPageFields(i))
                   .Orientation = xlPageField
                   .Subtotals = Array( _
                     False, False, False, False, False, False, _
                     False, False, False, False, False, False)
                End With
            Next i

'           Add Pivot Table Row Fields
            For i = 0 To UBound(sRowFields())
                If sRowFields(i) <= "" Then Exit For
                With .PivotFields(sRowFields(i))
                   .Orientation = xlRowField
                   .Subtotals = Array( _
                     False, False, False, False, False, False, _
                     False, False, False, False, False, False)
                End With
            Next i

'           Add Pivot Table Column Fields
            For i = 0 To UBound(sColumnFields())
                If sColumnFields(i) <= "" Then Exit For
                With .PivotFields(sColumnFields(i))
                   .Orientation = xlColumnField
                   .Subtotals = Array( _
                     False, False, False, False, False, False, _
                     False, False, False, False, False, False)
                End With
            Next i

'           Add Pivot Table Data Fields, Function & Format
            For i = 0 To UBound(sDataFields(), 1)
                If sDataFields(i, 0) <= "" Then Exit For
                With .PivotFields(sDataFields(i, 0))
                    .Orientation = xlDataField
                    If sDataFields(i, 1) <= "" Then sDataFields(i, 1) = "Count"
                    Select Case UCase(sDataFields(i, 1))
                        Case Is = "SUM"
                            .Function = xlSum
                        Case Is = "AVERAGE"
                            .Function = xlAverage
                        Case Is = "MAX"
                            .Function = xlMax
                        Case Is = "MIN"
                            .Function = xlMin
                        Case Is = "COUNTNUMS"
                            .Function = xlCountNums
                        Case Is = "PRODUCT"
                            .Function = xlProduct
                        Case Is = "STDEVP"
                            .Function = xlStDevP
                        Case Else
                            .Function = xlCount
                    End Select
                    .NumberFormat = "#,###.00_);[Red](#,###.00)"
                    If sDataFields(i, 2) <= "" Then sDataFields(i, 2) = _
                       sDataFields(i, 1) & " of " & sDataFields(i, 0)
                    .Caption = sDataFields(i, 2)
                End With
            Next i

'           Sort columns and rows
            For i = 0 To UBound(sSortFields(), 1)
                If sSortFields(i, 0) <= "" Then Exit For
                If sSortFields(i, 1) = "Descending" Then
                    .PivotFields(sSortFields(i, 0)).AutoSort _
                    xlDescending, sSortFields(i, 2)
                Else
                    .PivotFields(sSortFields(i, 0)).AutoSort _
                    xlAscending, sSortFields(i, 2)
                End If
            Next i

'           Restrict to top/bottom entries
            For i = 0 To UBound(sMaxFields(), 1)
                If sMaxFields(i, 0) <= "" Then Exit For
                If sMaxFields(i, 1) > 0 Then
                    .PivotFields(sMaxFields(i, 0)).AutoShow _
                    xlAutomatic, xlTop, Val(sMaxFields(i, 1)), sMaxFields(i, 2)
                Else
                    .PivotFields(sMaxFields(i, 0)).AutoShow _
                    xlAutomatic, xlBottom, Val(sMaxFields(i, 1)) * -1, _
                        sMaxFields(i, 2)
                End If
            Next i
        End With

 '      Orient datafields in columns
        If UBound(sDataFields(), 1) > 0 Then
            With ActiveSheet.PivotTables(sWorksheet).DataPivotField
                .Orientation = xlColumnField
                .Position = 1
            End With
        End If

'       Freeze panes on row and column titles
        Range(ActiveSheet.PivotTables(sWorksheet).DataBodyRange.Address). _
            Cells(1, 1).Select
        ActiveWindow.FreezePanes = True
   
    End If

'   Add Worksheet Title
    With Worksheets(sWorksheet)
        .Rows("1:1").MergeCells = False
        Range(.Cells(1, 1), .Cells(1, .PivotTables(sWorksheet).TableRange1. _
            Columns.Count)).Merge
        .Cells(1, 1) = sTitle
        .Cells(1, 1).Font.Bold = True
        .Cells(1, 1).HorizontalAlignment = xlHAlignLeft
    End With
       
    Setup_Pivot = Success               'Successful finish

ErrHandler:  
    If Err.Number <> 0 Then MsgBox _
        "Setup_Pivot - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    Settings "Restore"                  'Restore active window & settings
    On Error GoTo 0
End Function


Function Setup_PivotChart(sChartSheet As String, sWorksheet As String, _
                          lChartType As XlChartType, sTitle As String) As Boolean
'   Setup_PivotChart:Set up a Pivot Table Chart
'   Parameters:
'       sChartSheet  - The chartsheet to be created to contain the chart
'       sWorkSheet   - The worksheet name where the Pivot Table data is
'       sChartType   - The type of chart to created
'   Example:    Setup_PivotChart "chtHrs", "pvtHrs", "BarClustered"
'     Date   Init Modification
'   01/12/06 CWH  Initial Programming
'   05/15/09 CWH  Changed sChartType to lChartType to add flexibility
    On Error GoTo ErrHandler            '
    Setup_PivotChart = Failure          'Assume the Worst
               
    Settings "Save"
    Settings "Disable"
   
'   Dim Statements
    Dim i As Integer
    Dim n As Integer
   
'   Create Chart
    Worksheets(sWorksheet).Activate
    If Not ChartExists(sChartSheet) Then
        Charts.Add
        Charts(ActiveChart.Name).Name = sChartSheet
    End If
   
    Charts(sChartSheet).Activate

    ActiveChart.SetSourceData Source:=Sheets(sWorksheet). _
        Range(Sheets(sWorksheet).PivotTables(1).RowRange.Address)
    ActiveChart.Location WHERE:=xlLocationAsNewSheet
    
'   Plot Area Formatting
    ActiveChart.PlotArea.Fill.OneColorGradient _
        Style:=msoGradientDiagonalUp, Variant:=2, Degree:=1
    ActiveChart.PlotArea.Fill.ForeColor.SchemeColor = 36
   
    ActiveChart.ChartType = lChartType
    
'   Series Formatting - Choose Variant 1 for Columns and Area, 2 for Bars
    For i = 1 To ActiveChart.SeriesCollection.Count
        If lChartType = xlPie Or lChartType = xl3DPie _
           Or lChartType = xl3DPieExploded Then
            On Error Resume Next
            For n = 1 To ActiveChart.SeriesCollection(i).Points.Count
                ActiveChart.SeriesCollection(i).Points(n).Fill.ForeColor. _
                    SchemeColor = _
                    Choose((n Mod 10) + 1, 2, 5, 13, 3, 6, 4, 50, 11, 18, 9)
                ActiveChart.ApplyDataLabels
                ActiveChart.SeriesCollection(i).DataLabels.Font.Bold = True
                ActiveChart.SeriesCollection(i).DataLabels.Font.Color = _
                    RGB(255, 255, 255)
                ActiveChart.SeriesCollection(i).DataLabels.Font.Size = 12
                ActiveChart.SeriesCollection(i).DataLabels.NumberFormat = _
                    "#,###.00_);[Red](#,###.00)"
            Next n
            On Error GoTo ErrHandler
        Else
            ActiveChart.SeriesCollection(i).Fill.ForeColor.SchemeColor = _
                Choose((i Mod 10) + 1, 2, 5, 13, 3, 6, 4, 50, 11, 18, 9)
        End If
    Next i
       
    With Charts(sChartSheet)
        .HasTitle = True
        .ChartTitle.Text = sTitle
    End With
   
    Setup_PivotChart = Success           'Successful finish

ErrHandler:   
    If Err.Number <> 0 Then MsgBox _
        "Setup_PivotChart - Error#" & Err.Number & vbCrLf & Err.Description, _
        vbCritical, "Error", Err.HelpFile, Err.HelpContext
    Settings "Restore"
    On Error GoTo 0
End Function


Function Do_Pivot() As Boolean
    On Error GoTo ErrHandler

    Do_Pivot = Failure                  'Assume the Worst

    With Range(sDataRange)
        Names.Add sDataWithCaptionRange, Range(.Cells(1, 1).Offset(-1, 0), .Cells(.Rows.Count, .Columns.Count))
    End With

'   NOTE TO PGMR: Modify array dimensions (usually not required)
'                 0 = the first element so a dimension of 1 means 2 elements
'                 Changes are required ONLY if you want MORE than 1 element
    Dim sPageFields(0) As String              '0=# of Page Fields   (Optional)
    Dim sRowFields(0) As String               '0=# of Row Fields    (Required)
    Dim sColumnFields(1) As String            '0=# of Column Fields (Recommended)
    Dim sDataFields(0, 2) As String           '0=# of Data Field    (Required)
    Dim sMaxFields(0, 2) As String            '0=# of Restrictions  (Optional)
    Dim sSortFields(0, 2) As String           '0=# of Sort fields   (Optional)
'   NOTE TO PGMR: End modifications to array dimensions

'   NOTE TO PGMR: Set parameter values. Set to "" for optional parameters you
'                 don't want or delete the parameter line from this routine
    sPageFields(0) = "Страна"             'Allow filtering entire pivot on this
    sRowFields(0) = "Регион"              'This field goes down the side
    sColumnFields(0) = "Год"              'This field goes across the top
    sColumnFields(1) = "Квартал"          'This field goes across the top
    sDataFields(0, 0) = "Продажи"         'This field goes in the body
    sDataFields(0, 1) = "SUM"             'Calculation performed
    sDataFields(0, 2) = "Сумма продаж"    'Name for the calculated result
    
    sMaxFields(0, 0) = ""                 'This field is restricted
    sMaxFields(0, 1) = ""                 'To the top n values
    sMaxFields(0, 2) = ""                 'based on this field's value
    sSortFields(0, 0) = "Регион"          'This field is sorted
    sSortFields(0, 1) = "Ascending"       'in Ascending/Descending order
    sSortFields(0, 2) = "Сумма продаж"           'based on this field's value
'   NOTE TO PGMR: End modification to parameter values

'   Create the Pivot Table
    Setup_Pivot sPivotTableWorksheet, sDataWithCaptionRange, sTitle, _
                sPageFields(), sRowFields(), sColumnFields(), sDataFields(), _
                sSortFields(), sMaxFields()

'   Create a chart based on the pivot table (Optional)
    Setup_PivotChart sPivotChartWorksheet, sPivotTableWorksheet, sChartType, sTitle

    Do_Pivot = Success                  'Successful finish

ErrHandler:
        If Err.Number <> 0 Then MsgBox _
            "Do_Pivot - Error#" & Err.Number & vbCrLf & Err.Description, _
            vbCritical, "Error", Err.HelpFile, Err.HelpContext
        On Error GoTo 0
End Function


Private Sub Workbook_Open()
    Dim bResult As Boolean
    bResult = Do_Pivot()
        
    If WorkSheetExists(sPivotTableWorksheet) Then
        Worksheets(sPivotTableWorksheet).Activate
    End If
End Sub



Большая часть кода взята с ресурса офигенного гуру VBA - Craig Hatmaker
За что я ему очень благодарен!


P.S. Если вы будете использовать данный пример как основу для своих отчетов, то вот краткая инструкция по применению:
1) Создайте свой Excel-шаблон разметки.
2) Убедитесь, что он корректно заполняется данными, будучи используемым в BIPublisher отчете.
3) Важно, чтобы ваши "сырые" данные, отображаемые на листе Data (можете назвать этот лист как угодно, можете вообще скрыть его), предварялись заголовочной строкой.
4) Скопируйте VBA-код выше в Workbook-модуль своего Excel-файла шаблона.
5) Внесите изменения в определение констант в самом начале кода:
Const sPivotTableWorksheet = "Pivot Table"                               'Name for the PivotTable Worksheet
Const sPivotChartWorksheet = "Pivot Chart"                               'Name for the PivotChart Worksheet
Const sDataRange = "XDO_GROUP_?ROW?"                                     'Named range containing raw data
Const sDataWithCaptionRange = "XDO_RAW_DATA"                             'Named range containing raw data with captions
Const sTitle = "Продажи по регионам"                                     'PivotTable's title
Const sChartType = xlColumnStacked                                        'Chart type to create (Optional)

Самое главное здесь – задать верное название именованного диапазона, который будет содержать ваши "сырые" данные (константа sDataRange).
Типы диаграмм (константа sChartType) можно посмотреть здесь.
6) Внесите изменения в теле функции Do_Pivot()
А именно – поменяйте размерность массивов для различных разделов сводной таблицы, если планируете другое кол-во элементов в них. И задайте значения всем элементам этих массивов.

Комментариев нет:

Отправить комментарий