Bulk reporting

The TM1->Print Report function from Perspectives is useful to generate static reports in bulk for a given set of elements.
The following code is mimicking and extending that functionality to achieve bulk reporting for a TM1 report in a more flexible fashion.
For example you could get a report based on the branches of a company to be saved in each respective branch documents folder instead of getting them all dumped in a single folder or you could also get each branch report emailed to its own branch manager.

Here is the Excel VBA code:

Option Explicit
 
Sub BulkReport()
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=359
'+ admin@bihints mods
'+ some of Martin Ryan code
    Dim NewName As String
    Dim nm As Name
    Dim ws As Worksheet
    Dim TM1Element As String
    Dim i As Integer
    Dim myDim As String
    Dim server As String
    Dim fullDim As String
    Dim total As Long
    Dim folder As String
    Dim destination As String
    
    destination = "\\path\to\Your Branch Documents\"
    server = "tm1server"
    myDim = "Store"
    fullDim = server & ":" & myDim
    If Run("dimix", server & ":}Dimensions", myDim) = 0 Then
        MsgBox "The dimension does not exist on this server"
        Exit Sub
    End If

    'loop over all elements of the branch dimension
    For i = 1 To Run("dimsiz", fullDim)

        TM1Element = Run("dimnm", fullDim, i)
 
        'see if there are any sales for that branch
        total = Application.Run("DBRW", Range("$B$1").Value, "All Staff", Range("$B$7").Value, TM1Element, Range("$B$8").Value, "Total Sales")        
        'process only level 0 elements and sales <> 0 otherwise skip it
        If ((Application.Run("ellev", fullDim, TM1Element) = 0) And (total <> 0)) Then
          
            'update the dimension
            Range("$B$9").Value = "=SUBNM(""" & fullDim & """, """", """ & TM1Element & """, ""Name"")"
            'refresh worksheet
            Application.Run ("TM1RECALC")
                
                With Application
                    .ScreenUpdating = False
                     
                     '       Copy specific sheets
                     '       *SET THE SHEET NAMES TO COPY BELOW*
                     '       Array("Sheet Name", "Another sheet name", "And Another"))
                     '       Sheet names go inside quotes, seperated by commas
                    On Error GoTo ErrCatcher
                    'Sheets(Array("Sheet1", "CopyMe2")).Copy
                    Sheets(Array("Sheet1")).Copy
                    On Error GoTo 0
                     
                     '       Paste sheets as values
                     '       Remove External Links, Hperlinks and hard-code formulas
                     '       Make sure A1 is selected on all sheets
                    For Each ws In ActiveWorkbook.Worksheets
                        ws.Cells.Copy
                        ws.[A1].PasteSpecial Paste:=xlValues
                        ws.Cells.Hyperlinks.Delete
                        Application.CutCopyMode = False
                        Cells(1, 1).Select
                        ws.Activate
                    Next ws
                    Cells(1, 1).Select
                     
                     'Remove named ranges except print settings
                    For Each nm In ActiveWorkbook.Names
                        If nm.NameLocal <> "Sheet1!Print_Area" And nm.NameLocal <> "Sheet1!Print_Titles" Then
                            nm.Delete
                        End If
                    Next nm
                     
                     'name report after the branch name
                    NewName = Left(Range("$B$9").Value, 4)
                     
                     'Save it in the branch folder of the same name
                    folder = Dir(destination & NewName & "*", vbDirectory)
   
                    ActiveWorkbook.SaveCopyAs destination & folder & "\" & NewName & "_report.xls"
                    'skip save file confirmation
                    ActiveWorkbook.Saved = True
                    ActiveWorkbook.Close SaveChanges:=False
                    .ScreenUpdating = True
                End With
                
        End If
    Next i
    
    Exit Sub
     
ErrCatcher:
    MsgBox "Specified sheets do not exist within this workbook"
End Sub
Categories

Add new comment

The content of this field is kept private and will not be shown publicly.

Plain text

  • No HTML tags allowed.
  • Lines and paragraphs break automatically.
  • Web page addresses and email addresses turn into links automatically.