VBA - Bulk Reporting; including subsets
Posted: Mon Aug 01, 2011 4:53 pm
Good Afternoon,
I'm looking for some guidance on amending the following VBA code to not only create reports based on department codes which are n level items, but also create reports based on subsets which amalgamate numerous departments - for those managers controlling larger teams.
Any advice would be appreciated. I'm currently struggling to see what i need to update and how.
Many thanks in advance
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
Dim Department, RowStart, RowEnd As Long
Dim ThisWorkbook, ThatWorkbook, OpexCurrency, Comparison, Company, OpexMeasure, Period As String
Dim OpexDept, Year As Long
destination = Sheets("Front Sheet").Range("F12")
server = "domforecast2"
myDim = "OraDept"
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)
'Name reference points for use later in macro
Sheets("Front Sheet").Select
ThisWorkbook = ActiveWorkbook.Name
Period = Range("F5")
Year = Range("F6")
Company = Range("F7")
Comparison = Range("F8")
OpexCurrency = Range("F9")
VVersion = Range("F10")
OpexMeasure = Range("F11")
'see if there are any sales for that branch
total = Application.Run("DBRW", "domforecast2:OracleOpexReporting", Range("F5").Value, Range("F6").Value, Range("F9").Value, Range("F10").Value, Range("F7").Value, TM1Element, Range("F11").Value)
'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
Sheets("Opex Report").Range("$E$5").Value = "=SUBNM(""" & fullDim & """, """", """ & TM1Element & """, ""Name"")"
Sheets("Opex Report").Range("$B$8").Value = "=SUBNM(""" & fullDim & """, """", """ & TM1Element & """, ""Description"")"
'refresh worksheet
Application.Run ("TM1RECALC")
Sheets("Opex Month View").Select
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("Opex Report", "Opex Month View")).Select
Sheets("Opex Month View").Activate
Sheets(Array("Opex Report", "Opex Month View")).Copy
Sheets("Opex Report").Activate
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
ThatWorkbook = ActiveWorkbook.Name
Sheets("Opex Report").Select
Cells.Select
Application.CutCopyMode = False
With Selection
.MergeCells = False
End With
Selection.AutoFilter Field:=1
Cells.Copy
Range("A1").PasteSpecial Paste:=xlValues
Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="1"
Cells(1, 1).Select
Sheets("Opex Month View").Select
Cells.Select
Application.CutCopyMode = False
With Selection
.MergeCells = False
End With
Cells.Copy
Range("A1").PasteSpecial Paste:=xlValues
Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
Sheets("Opex Report").Select
Range("A1").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 & Period & "_" & Year & "_Dept" & TM1Element & ".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
I'm looking for some guidance on amending the following VBA code to not only create reports based on department codes which are n level items, but also create reports based on subsets which amalgamate numerous departments - for those managers controlling larger teams.
Any advice would be appreciated. I'm currently struggling to see what i need to update and how.
Many thanks in advance
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
Dim Department, RowStart, RowEnd As Long
Dim ThisWorkbook, ThatWorkbook, OpexCurrency, Comparison, Company, OpexMeasure, Period As String
Dim OpexDept, Year As Long
destination = Sheets("Front Sheet").Range("F12")
server = "domforecast2"
myDim = "OraDept"
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)
'Name reference points for use later in macro
Sheets("Front Sheet").Select
ThisWorkbook = ActiveWorkbook.Name
Period = Range("F5")
Year = Range("F6")
Company = Range("F7")
Comparison = Range("F8")
OpexCurrency = Range("F9")
VVersion = Range("F10")
OpexMeasure = Range("F11")
'see if there are any sales for that branch
total = Application.Run("DBRW", "domforecast2:OracleOpexReporting", Range("F5").Value, Range("F6").Value, Range("F9").Value, Range("F10").Value, Range("F7").Value, TM1Element, Range("F11").Value)
'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
Sheets("Opex Report").Range("$E$5").Value = "=SUBNM(""" & fullDim & """, """", """ & TM1Element & """, ""Name"")"
Sheets("Opex Report").Range("$B$8").Value = "=SUBNM(""" & fullDim & """, """", """ & TM1Element & """, ""Description"")"
'refresh worksheet
Application.Run ("TM1RECALC")
Sheets("Opex Month View").Select
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("Opex Report", "Opex Month View")).Select
Sheets("Opex Month View").Activate
Sheets(Array("Opex Report", "Opex Month View")).Copy
Sheets("Opex Report").Activate
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
ThatWorkbook = ActiveWorkbook.Name
Sheets("Opex Report").Select
Cells.Select
Application.CutCopyMode = False
With Selection
.MergeCells = False
End With
Selection.AutoFilter Field:=1
Cells.Copy
Range("A1").PasteSpecial Paste:=xlValues
Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Selection.AutoFilter Field:=1, Criteria1:="1"
Cells(1, 1).Select
Sheets("Opex Month View").Select
Cells.Select
Application.CutCopyMode = False
With Selection
.MergeCells = False
End With
Cells.Copy
Range("A1").PasteSpecial Paste:=xlValues
Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
Sheets("Opex Report").Select
Range("A1").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 & Period & "_" & Year & "_Dept" & TM1Element & ".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