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