My teams use Hyperion Essbase to pull data in all of their workbooks. To pull data, teams previously had to locate data pulls within a workbook, and manually pull the data. In large workbooks, this is tedious. Macros could be written by someone with knowledge of VBA to automate the data pulls, however VBA knowledge across teams is limited and makes this difficult to implement in a large scale across files and teams.
To solve this, I developed VBA code that completely automates the process of locating data pulls, writing macros to automate the data pulls, and many more operations on any workbook.
The VBA code was housed in an excel template file which could be easily shared. The user would then press the “Export Template” button as in the photo below.
Pressing the button triggered the following dialogue box. Users would select their destination workbook including all of their data pulls to easily import my code into their workbook.
Once imported, the user would simply press the ‘Populate Sheet List’ button and my code would parse through the workbook, find all worksheet names, the date the sheet’s data was last pulled, and all of the named ranges on the worksheet where data pulls were housed. The user could then perform a number of operations. They can “Refresh Essbase” to refresh all of the data pulls indicated with a ‘yes’ in the ‘Refresh?’ column. The user could toggle refreshes on and off to easily select specific data pulls while omitting unnecessary data pulls. The user could hide, unhide, protect, and unprotect the selected worksheets as well.
Finally, the user could ‘Save Refresh as Macro’. This would take the dashboard’s current selections, write a macro that performs the data pull specifically for those selections, creates a button, and maps the created macro to the button. This would allow the user to, without any technical knowledge of VBA or Hyperion, create macros that allowed them to do custom data pulls and other operations on their workbooks. See below the dialogue box that appears after pressing the ‘Save’ button and see how a custom button is created with the custom macro.
This project was revolutionary for the way teams in Corporate Finance perform data pulls in Hyperion Essbase. It removed much room for human error while empowering users without technical knowledge of VBA to perform complex operations and save them for stress-free use.
The code for this solution is below including annotations explaining the purpose of each segment. The template also included user forms and associated code that it not defined below but are referenced below. Their definitions are stored in a separate location within the excel file.
Option Explicit
''' Code developed by Riley Dunnaway on 09/19/2023.
''' Dynamically locates and refreshes all essbase retrieves within any workbook
Option Compare Text
Public MyFile As String
Public Stopped As Boolean
''' ESSBASE FUNCTIONS '''
''' These functions are used by essbase under the hood when performing retrieves''''
''' Do not alter or remove''''
Dim oAddin As COMAddIn
Dim oCOMFuncs As Object
Dim Initiated As Boolean
Private Sub initiate_essbase()
Set oAddin = Application.COMAddIns("SmartSend")
Set oCOMFuncs = oAddin.Object
Initiated = True
End Sub
Function SSConnect(System As String, Optional userid As String = "", Optional password As String = "") As Boolean
If Not Initiated Then initiate_essbase
SSConnect = oCOMFuncs.SSConnect(System, userid, password)
End Function
Function SSSend(Optional sheetName As String = "", Optional RangeName As String = "", Optional ForceSendAll As Boolean = False) As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSSend = oCOMFuncs.SSSend(ForceSendAll)
End Function
Function SSSendAdd(Optional sheetName As String = "", Optional RangeName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSSendAdd = oCOMFuncs.SSSendAdd()
End Function
Function SSSendSubtract(Optional sheetName As String = "", Optional RangeName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSSendSubtract = oCOMFuncs.SSSendSubtract()
End Function
Function SSRetrieve(Optional sheetName As String = "", Optional RangeName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSRetrieve = oCOMFuncs.SSRetrieve()
End Function
Function SSKeepOnly(Optional sheetName As String = "", Optional RangeName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSKeepOnly = oCOMFuncs.SSKeepOnly()
End Function
Function SSRemoveOnly(Optional sheetName As String = "", Optional RangeName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSRemoveOnly = oCOMFuncs.SSRemoveOnly()
End Function
Function SSZoomIn(Optional sheetName As String = "", Optional RangeName As String = "", Optional Selection As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
Dim address As String
address = ""
If RangeName <> "" Then address = Range(RangeName).address
If Selection <> "" Then
If address <> "" Then address = address + ","
address = address + Range(Selection).address
End If
If address <> "" Then Range(address).Select
SSZoomIn = oCOMFuncs.SSZoomIn()
End Function
Function SSZoomOut(Optional sheetName As String = "", Optional RangeName As String = "", Optional Selection As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
Dim address As String
address = ""
If RangeName <> "" Then address = Range(RangeName).address
If Selection <> "" Then
If address <> "" Then address = address + ","
address = address + Range(Selection).address
End If
If address <> "" Then Range(address).Select
SSZoomOut = oCOMFuncs.SSZoomOut()
End Function
Function SSFlashBack(Optional sheetName As String = "", Optional RangeName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
If RangeName <> "" Then Range(RangeName).Select
SSFlashBack = oCOMFuncs.SSFlashBack()
End Function
Function SSOptions() As Boolean
If Not Initiated Then initiate_essbase
SSOptions = oCOMFuncs.SSOptions()
End Function
Function SSNavigateWithoutData() As Boolean
If Not Initiated Then initiate_essbase
SSNavigateWithoutData = oCOMFuncs.SSNavigateWithoutData()
End Function
Function SSMemberSelector(Optional sheetName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
SSMemberSelector = oCOMFuncs.SSMemberSelector()
End Function
Function SSCalculation() As Boolean
If Not Initiated Then initiate_essbase
SSCalculation = oCOMFuncs.SSCalculation()
End Function
Function SSESBConnect(sheetName As String, Optional userid As String = "", Optional password As String = "", Optional Server As String = "", Optional Application As String = "", Optional Database As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
SSESBConnect = oCOMFuncs.SSESBConnect(userid, password, Server, Application, Database)
End Function
Function SSEsbDisconnect() As Boolean
If Not Initiated Then initiate_essbase
SSEsbDisconnect = oCOMFuncs.SSEsbDisconnect()
End Function
Function SSRunReport(ReportName As String, Optional Parm1 As String = "", Optional Parm2 As String = "", Optional Parm3 As String = "", Optional Parm4 As String = "", Optional Parm5 As String = "", Optional Parm6 As String = "", Optional Parm7 As String = "", Optional Parm8 As String = "", Optional Parm9 As String = "", Optional Parm10 As String = "", Optional Parm11 As String = "", Optional Parm12 As String = "", Optional Parm13 As String = "", Optional Parm14 As String = "", Optional Parm15 As String = "", Optional Parm16 As String = "", Optional Parm17 As String = "", Optional Parm18 As String = "", Optional Parm19 As String = "", Optional Parm20 As String = "") As Boolean
If Not Initiated Then initiate_essbase
SSEsbRunReport = oCOMFuncs.SSRunReport(ReportName, Parm1, Parm2, Parm3, Parm4, Parm5, Parm6, Parm7, Parm8, Parm9, Parm10, Parm11, Parm12, Parm13, Parm14, Parm15, Parm16, Parm17, Parm18, Parm19, Parm20)
End Function
Function SSAdHocTemplate() As Boolean
If Not Initiated Then initiate_essbase
SSAdHocTemplate = oCOMFuncs.SSAdHocTemplate()
End Function
Function SSListActiveDirectoryGroup(GroupName As String) As Boolean
If Not Initiated Then initiate_essbase
SSListActiveDirectoryGroup = oCOMFuncs.SSListActiveDirectoryGroup(GroupName)
End Function
Function SSSetSheetOption(item As Integer, value As Variant, Optional sheetName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
SSSetSheetOption = oCOMFuncs.SSSetSheetOption(item, value)
End Function
Function SSSetGlobalOption(item As Integer, value As Variant) As Boolean
If Not Initiated Then initiate_essbase
SSSetGlobalOption = oCOMFuncs.SSSetGlobalOption(item, value)
End Function
Function SSEsbSend(Optional sheetName As String = "") As Boolean
If Not Initiated Then initiate_essbase
If sheetName <> "" Then Sheets(sheetName).Select
SSEsbSend = oCOMFuncs.SSEsbSend()
End Function
''' Runs retrieves for all retrievs in refresh dashboard '''
Sub Refresh_Dashboard()
'''' Declaring all variables that will be used throughout the code''''
Dim Sheet_Names As Range
Dim Cell As Range
Dim Cell2 As Range
Dim sheetName As String
Dim range1 As String
Dim sheetRange As String
Dim lr As Long
Dim lr2 As Long
Dim named_ranges As Range
Dim viz_track As Boolean
'Dim listStart As Range
'''' Freezes screen while macro is running ''''
Application.ScreenUpdating = False
'''' Grabs sheet names from table in Refresh Dashboard '''
'Set listStart = Range("B4")
viz_track = False
'lr = Worksheets("Refresh Dashboard").Cells(Rows.Count, "B").End(xlUp).Row
If Range("B4").value <> vbNullString Then
If Range("B5").value = vbNullString Then
lr = 1
ElseIf Range("B5").value <> vbNullString Then
lr = Worksheets("Refresh Dashboard").Range(Range("B4"), Range("B4").End(xlDown)).Rows.Count
End If
End If
'Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B4" & lr)
Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B" & lr + 3)
''' Iterates through each sheet (Cell) name within Sheet_Names in the Refresh Dashboard table. One sheet name at a time '''
''' All of the below actions are repeated for each sheet identified by the Populate Sheet List Macro '''
For Each Cell In Sheet_Names
''' Checks if Refresh? is set to Yes or No '''
If Cell.Offset(, 1).value = "Yes" Then
If Worksheets(Cell.value).Visible = False Then
Worksheets(Cell.value).Visible = True
viz_track = True
End If
''' Checks how many Retrieve Named Ranges are the row of current Cell''''
lr2 = Worksheets("Refresh Dashboard").Range(Cell, Cell.End(xlToRight)).Columns.Count
'''' Sets named_ranges to all the named ranges in the row of current Cell '''
Set named_ranges = Worksheets("Refresh Dashboard").Range(Cell.Offset(, 3), Cell.Offset(, lr2 - 1))
If Cell.Offset(, 3).value = vbNullString Then
GoTo NoCells
End If
''''' Iterates through each named range (Cell2) with the list named_ranges one at a time ''''
For Each Cell2 In named_ranges
'''' Sets sheetName and range1 to the sheet (Cell) and named range (Cell2) currently iterated in the two For loops ''''
sheetName = Cell.value
range1 = Cell2.value
''' Checks named range for what database should be accessed and performs appropriate Essbase retrieval ''''
If Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "MRFSTRES'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'MRFSTRES'" Then
SSESBConnect sheetName, , , "ESSPRD.US.BANK-DNS.COM", "MrfStres", "Forecast"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
ElseIf Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "MRUSB'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'MRUSB'" Then
SSESBConnect sheetName, , , "EssPrd.US.BANK-DNS.COM", "MRUSB", "mrdata"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
ElseIf Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "MRFSSTAT'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'MRFSSTAT'" Then
SSESBConnect sheetName, , , "EssPrd.US.BANK-DNS.COM", "MrfSStat", "MrfSStat"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
ElseIf Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "GLUSB'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'GLUSB'" Then
SSESBConnect sheetName, , , "CDW", "GLusb", "GLusb"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
ElseIf Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "MRTP'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'MRTP'" Then
SSESBConnect sheetName, , , "CDW", "MRTP", "MRTP"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
ElseIf Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "MRFMED'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'MRFMED'" Then
SSESBConnect sheetName, , , "EssPrd.US.BANK-DNS.COM", "MrfMED", "MRfMED"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
ElseIf Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "MRFCST'" Or Worksheets(sheetName).Range(Cell2).Cells(3, 1).value = "'MRFCST'" Then
SSESBConnect sheetName, , , "EssPrd.US.BANK-DNS.COM", "MRFCST", "FORECAST"
SSRetrieve sheetName, range1
SSEsbDisconnect
If Worksheets(sheetName).ProtectContents = True Then
Worksheets(sheetName).Unprotect
Call Timestamp(sheetName, Cell2)
Worksheets(sheetName).Protect
Else
Call Timestamp(sheetName, Cell2)
End If
End If
Next
End If
If viz_track = True Then
viz_track = False
Worksheets(Cell.value).Visible = False
End If
NoCells:
Next
''' Sorts Refresh Dashboard by last refresh date ''''
Sort_Refresh_Dashboard
'''' Unfreezes screen and returns to dashboad ''''
Worksheets("Refresh Dashboard").Activate
Worksheets("Refresh Dashboard").Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox ("Finished!")
End Sub
'Alternative Saved code that changes all retrieve ranges from global to local. May decrease errors.
'Sub Format_Named_Ranges()
' 'Changes all GLOBAL RETRIEVES to local
' Dim nm As Name, Ans As Integer, newNm As String, named_range As String, sheet_name As String
' For Each nm In ActiveWorkbook.Names
' named_range = Right(nm.Name, Len(nm.Name) - InStr(nm.Name, "!"))
' If Not (nm.Name Like "*!*") And Left(named_range, 8) = "Retrieve" Then 'It is global level retrieve named range that should be changed
' sheet_name = Split(nm, "!")(0)
' sheet_name = Split(sheet_name, "=")(1)
' sheet_name = Replace(sheet_name, "'", "")
' newNm = sheet_name & "!" & named_range
' Worksheets(sheet_name).Names.Add nm.Name, nm
' nm.Delete
' End If
' Next nm
'End Sub
'''' Sorts Refresh Dashboard by last refresh date ''''
Sub Sort_Refresh_Dashboard()
ActiveWorkbook.Worksheets("Refresh Dashboard").Sort.SortFields.Add2 Key:=Range(Range("D4"), Range("D4").End(xlDown)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Refresh Dashboard").Sort
.SetRange Range("B4:R100")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("Refresh Dashboard").Sort.SortFields.Clear
End Sub
'''' Timestamps retrieves after being completed ''''
Sub Timestamp(sheetName, Cell)
Worksheets(sheetName).Range(Cell).Cells(1, 1).value = "'Last Refresh:'"
On Error GoTo skipFormat
Worksheets(sheetName).Range(Cell).Cells(2, 1).NumberFormat = ("m/d/yyyy h:mm")
skipFormat:
Worksheets(sheetName).Range(Cell).Cells(2, 1).value = Now()
Worksheets(sheetName).Range(Cell).Range(Cells(1, 1), Cells(2, 1)).HorizontalAlignment = xlLeft
End Sub
'''' Populates Refresh Dashboard '''
Sub List_Refresh_Sheets()
''' Freezes Screen while Macro is running'''
Application.ScreenUpdating = False
'''' Declaring all variables that will be used in the code '''
Dim ws As Worksheet
Dim x As Integer
Dim y As Integer
Dim index As Integer
Dim index_end As Integer
Dim nm As Name
Dim named_range As String
Dim sheet_name As String
Dim yes_column As Range
Dim Cell As Range
Dim date_column As Range
''' x and y are counters used by the program to calculate how many iterations the For loops go through '''
''' and place sheet named and named ranges in correct cells in tables ''''
''' set to 1 and 0 respectively to start and are increased by one each iteration ''''
x = 1
y = 0
'''' Clears current area in Refresh Dashboard '''
'Sheets("Refresh Dashboard").Range(Range("B4"), Range("B4").End(xlDown).End(xlDown)).Clear
'Sheets("Refresh Dashboard").Range(Range("E4").End(xlDown), Range("K4")).Clear
Sheets("Refresh Dashboard").Range("B4:R100").Clear
''' Located ESSBASE START-> and END sheets and saves their index (sheet place number)'''
index = Sheets("ESSBASE START ->").index
index_end = Sheets("<- ESSBASE END").index
'''Iterates through all worksheets in the workbook one at a time''''
For Each ws In Worksheets
'''' Checks that the current worksheet's index is between the ESSBASE START and ESSBASE END sheets
If ws.index > index And index_end > ws.index Then
'''' If inbetween the essbase sheets, adds sheet name to Refresh Dashboard in correct location ''''
Sheets("Refresh Dashboard").Cells(3 + x, 2) = ws.Name
''' Iterates through all named ranges in the workbook. Active.Workbook.Names could be switched to ws.Names if all retrieve ranges were local'''
'''' Currently accomodates globally saved named ranges which is more dynamic, but possibly more prone to errors. ''''
For Each nm In ActiveWorkbook.Names 'ws.Names
''' Grabs the named range's name as a string, also grabs named range's sheet name as a string ''''
named_range = Right(nm.Name, Len(nm.Name) - InStr(nm.Name, "!"))
sheet_name = Split(nm, "!")(0)
sheet_name = Split(sheet_name, "=")(1)
sheet_name = Replace(sheet_name, "'", "")
'''' Checks if the ranges sheet name is equal to the current sheet name. If not, range should is not placed in the same row as the current sheet name.''''
'''' If sheet_mame does equal the current worksheet name, then'''
'''' the program checks that range is a "Retrieve_" and a Visible worksheet'''
'''' If all of these conditions are true, the named range is added to the table together with the current worksheet'''
If sheet_name = ws.Name And Left(named_range, 8) = "Retrieve" And nm.Visible = True Then 'And nm.Parent.Name = ws.Name
Sheets("Refresh Dashboard").Cells(3 + x, 5 + y) = named_range
''' Counter is adjusted so the next named range is moved one cell over to next named ranges column'''
y = y + 1
End If
''' Proceeds to next worksheet and compares again all the named ranges to return only the named ranges on the next worksheet.'''
Next nm
'''' y resets to 0 because we are on the next row and named ranges will be placed in the first named ranges 1 column'''
'''' x counter is adjusted to we move down one row for the next worksheet'''
y = 0
x = x + 1
End If
''''Proceeds to next worksheet''''
Next ws
''' Adds a formula to the Refresh? column that automatically selects yes if there is a worksheet in the adjacent cell, blank if adjacent cell is blank.
Set yes_column = Sheets("Refresh Dashboard").Range("C4:C100")
yes_column.HorizontalAlignment = xlCenter
With yes_column.Validation
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="Yes,No"
End With
For Each Cell In yes_column
Cell.FormulaLocal = "=IF( OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -1) <> """", ""Yes"", """") "
Next
''' Adds formula that finds the date within the named range presented in adjacent cells in the Last Refresh Column.
Set date_column = Sheets("Refresh Dashboard").Range("D4:D100")
date_column.HorizontalAlignment = xlCenter
For Each Cell In date_column
''' The formula is pretty complex, but magically it finds the dates within each named range in each row of the Dashboard ''''
Cell.FormulaLocal = "=IFERROR(IF(INDEX(INDIRECT(""'""&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -2)&""'!""&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, 1)), 2, 1)>0,INDEX(INDIRECT(""'""&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -2)&""'!""&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, 1)), 2, 1),""""), """")"
Cell.NumberFormat = ("m/d/yyyy h:mm")
Next
''' Sorts Refresh Dashboard from Oldest refreshes to Newest
Sort_Refresh_Dashboard
''' Unfreezes Screen
Worksheets("Refresh Dashboard").Activate
Application.ScreenUpdating = True
End Sub
''''Macro Selects NO in Refresh? column''''
Sub Unselect_All_Refresh()
Application.ScreenUpdating = False
Dim yes_column As Range
Dim Cell As Range
''' If statements check how many entries are in the column and inputs the correct number of NO's ''''
If Range("B4").value <> vbNullString Then
If Range("B5").value = vbNullString Then
Set yes_column = Worksheets("Refresh Dashboard").Range("B4").Offset(0, 1)
ElseIf Range("B5").value <> vbNullString Then
Set yes_column = Worksheets("Refresh Dashboard").Range("B4", Range("B4").End(xlDown)).Offset(0, 1)
End If
For Each Cell In yes_column
Cell.value = "No"
Next
End If
Application.ScreenUpdating = True
End Sub
''''Macro Selects YES by injecting default formula in Refresh? column''''
'''' Does not need to check number of entries because excel formula returns blank if row is empty. ''''
Sub Select_All_Refresh()
Application.ScreenUpdating = False
Dim yes_column As Range
Dim Cell As Range
Set yes_column = Worksheets("Refresh Dashboard").Range("B4", Range("B4").End(xlDown)).Offset(0, 1)
For Each Cell In yes_column
'''' Inserts excel formula that checks if adjacent cell is empty and returns yes if not empty, empty if empty ''''
Cell.FormulaLocal = "=IF( OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -1) <> """", ""Yes"", """") "
Next
Application.ScreenUpdating = True
End Sub
'''' Calls Export_Selection user form to collect user target workbook for exporting '''
'''' Calls the subroutine Copy_Module to copy "Essbase_Dashboard" Module to target workbook ''''
'''' Copies worksheets to target workbook ''''
Sub Export_Template()
Stopped = False
Export_Selection.Show
If Stopped Then Exit Sub
Application.ScreenUpdating = False
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ThisWorkbook
On Error GoTo export_cancel
Set WB2 = Workbooks(MyFile)
Call Copy_Module(WB1, "Essbase_Dashboard", WB2)
WB1.Sheets("<- ESSBASE END").Copy Before:=Workbooks(MyFile).Sheets(1)
WB1.Sheets("ESSBASE START ->").Copy Before:=Workbooks(MyFile).Sheets(1)
WB1.Sheets("Refresh Dashboard").Copy Before:=Workbooks(MyFile).Sheets(1)
export_cancel:
Application.ScreenUpdating = True
End Sub
Private Sub Copy_Module(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)
Application.ScreenUpdating = False
Call Add_Reference
Call Copy_Prep(SourceWB, strModuleName, TargetWB)
Application.ScreenUpdating = True
End Sub
''' Copies the module "Essbase_Dashboard" to user's target workbook
Private Sub Copy_Prep(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)
Dim SourceVBProject As VBIDE.VBProject, DestinationVBProject As VBIDE.VBProject
Set SourceVBProject = SourceWB.VBProject
Dim NewWb As Workbook
Set NewWb = TargetWB
Set DestinationVBProject = NewWb.VBProject
Dim SourceModule As VBIDE.CodeModule, DestinationModule As VBIDE.CodeModule
Set SourceModule = SourceVBProject.VBComponents(strModuleName).CodeModule
Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
With SourceModule
DestinationModule.AddFromString .Lines(1, .CountOfLines)
End With
End Sub
''''Imports VBA Reference to Microsoft Visual Basic for Applications Extensibility Library
'''' This Library is used in the CopyModule subroutine and is necessary to export the file automatically
Private Sub Add_Reference()
'''Macro purpose: To add a reference to the project using the GUID for the
'''reference library
Dim strGUID As String, theRef As Variant, i As Long
'''Update the GUID you need below.
strGUID = "{0002E157-0000-0000-C000-000000000046}"
'''Set to continue in case of error
On Error Resume Next
'''Remove any missing references
For i = ThisWorkbook.VBProject.References.Count To 1 Step -1
Set theRef = ThisWorkbook.VBProject.References.item(i)
If theRef.IsBroken = True Then
ThisWorkbook.VBProject.References.Remove theRef
End If
Next i
'''Clear any errors so that error trapping for GUID additions can be evaluated
Err.Clear
'''Add the reference
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:=strGUID, Major:=1, Minor:=0
'''If an error was encountered, inform the user
Select Case Err.Number
Case Is = 32813
'''Reference already in use. No action necessary
Case Is = vbNullString
'''Reference added without issue
Case Else
'''An unknown error was encountered, so alert the user
MsgBox "A problem was encountered trying to" & vbNewLine _
& "add or remove a reference in this file" & vbNewLine & "Please check the " _
& "references in your VBA project!", vbCritical + vbOKOnly, "Error!"
End Select
On Error GoTo 0
End Sub
''' Hides sheets in Refresh Dashboard'''
Sub Hide_Dashboard()
'''' Declaring all variables that will be used throughout the code''''
Dim Sheet_Names As Range
Dim Cell As Range
Dim lr As Long
'''' Freezes screen while macro is running ''''
Application.ScreenUpdating = False
'''' Grabs sheet names from table in Refresh Dashboard '''
lr = Worksheets("Refresh Dashboard").Cells(Rows.Count, "B").End(xlUp).Row
Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B4" & lr)
''' Iterates through each sheet (Cell) name within Sheet_Names in the Refresh Dashboard table. One sheet name at a time '''
''' All of the below actions are repeated for each sheet identified by the Populate Sheet List Macro '''
For Each Cell In Sheet_Names
''' Checks if Refresh? is set to Yes or No, then hides worksheet '''
If Cell.Offset(, 1).value = "Yes" Then
Sheets(Cell.value).Visible = False
End If
Next
'''' Unfreezes screen and returns to dashboad ''''
Worksheets("Refresh Dashboard").Activate
Worksheets("Refresh Dashboard").Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
''' Unhides sheets in Refresh Dashboard'''
Sub Unhide_Dashboard()
'''' Declaring all variables that will be used throughout the code''''
Dim Sheet_Names As Range
Dim Cell As Range
Dim lr As Long
'''' Freezes screen while macro is running ''''
Application.ScreenUpdating = False
'''' Grabs sheet names from table in Refresh Dashboard '''
lr = Worksheets("Refresh Dashboard").Cells(Rows.Count, "B").End(xlUp).Row
Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B4" & lr)
''' Iterates through each sheet (Cell) name within Sheet_Names in the Refresh Dashboard table. One sheet name at a time '''
''' All of the below actions are repeated for each sheet identified by the Populate Sheet List Macro '''
For Each Cell In Sheet_Names
''' Checks if Refresh? is set to Yes or No, then unhides worksheet '''
If Cell.Offset(, 1).value = "Yes" Then
Sheets(Cell.value).Visible = True
End If
Next
'''' Unfreezes screen and returns to dashboad ''''
Worksheets("Refresh Dashboard").Activate
Worksheets("Refresh Dashboard").Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
''' Hides sheets in Refresh Dashboard'''
Sub Protect_Dashboard()
'''' Declaring all variables that will be used throughout the code''''
Dim Sheet_Names As Range
Dim Cell As Range
Dim lr As Long
'''' Freezes screen while macro is running ''''
Application.ScreenUpdating = False
'''' Grabs sheet names from table in Refresh Dashboard '''
lr = Worksheets("Refresh Dashboard").Cells(Rows.Count, "B").End(xlUp).Row
Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B4" & lr)
''' Iterates through each sheet (Cell) name within Sheet_Names in the Refresh Dashboard table. One sheet name at a time '''
''' All of the below actions are repeated for each sheet identified by the Populate Sheet List Macro '''
For Each Cell In Sheet_Names
''' Checks if Refresh? is set to Yes or No, then hides worksheet '''
If Cell.Offset(, 1).value = "Yes" Then
Sheets(Cell.value).Protect
End If
Next
'''' Unfreezes screen and returns to dashboad ''''
Worksheets("Refresh Dashboard").Activate
Worksheets("Refresh Dashboard").Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
''' Unhides sheets in Refresh Dashboard'''
Sub Unprotect_Dashboard()
'''' Declaring all variables that will be used throughout the code''''
Dim Sheet_Names As Range
Dim Cell As Range
Dim lr As Long
'''' Freezes screen while macro is running ''''
Application.ScreenUpdating = False
'''' Grabs sheet names from table in Refresh Dashboard '''
lr = Worksheets("Refresh Dashboard").Cells(Rows.Count, "B").End(xlUp).Row
Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B4" & lr)
''' Iterates through each sheet (Cell) name within Sheet_Names in the Refresh Dashboard table. One sheet name at a time '''
''' All of the below actions are repeated for each sheet identified by the Populate Sheet List Macro '''
For Each Cell In Sheet_Names
''' Checks if Refresh? is set to Yes or No, then unhides worksheet '''
If Cell.Offset(, 1).value = "Yes" Then
Sheets(Cell.value).Unprotect
End If
Next
'''' Unfreezes screen and returns to dashboad ''''
Worksheets("Refresh Dashboard").Activate
Worksheets("Refresh Dashboard").Range("A1").Select
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Sub Save_Refresh_Macro()
Application.ScreenUpdating = False
Call Add_Reference
Call Save_Prep
Application.ScreenUpdating = True
End Sub
Private Sub Save_Prep()
Dim Macro_Name As String
Dim lr As Long
Dim i As Long
Dim j As Long
Dim x As Long
Dim y As Long
Dim b As Button
Dim StartLine As Long
Dim Sheet_Names As Range
Dim Cell As Range
Dim sheetArray() As String
Dim temp_string As String
Dim btn As Button
Dim t As Range
Dim temp_numb As Long
Application.ScreenUpdating = False
''' Collects user's desired sheets to be run in custom macro ''''
If Range("B4").value <> vbNullString Then
If Range("B5").value = vbNullString Then
lr = 1
ElseIf Range("B5").value <> vbNullString Then
lr = Worksheets("Refresh Dashboard").Range(Range("B4"), Range("B4").End(xlDown)).Rows.Count
End If
ElseIf Range("B4").value = vbNullString Then
Exit Sub
End If
Set Sheet_Names = Worksheets("Refresh Dashboard").Range("B4", "B" & lr + 3)
''' Creates user's custom macro ''''
Macro_Name = InputBox("Please name your macro", "Name Macro")
Macro_Name = Replace(Macro_Name, " ", "_")
If Macro_Name = vbNullString Then
Exit Sub
End If
Dim SourceVBProject As VBIDE.VBProject
Dim DestinationModule As VBIDE.CodeModule
Set SourceVBProject = ActiveWorkbook.VBProject
Set DestinationModule = ActiveWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
DestinationModule.Name = Macro_Name
''' Sets user's sheets to an array ''''
ReDim sheetArray(1 To lr)
i = 1
For Each Cell In Sheet_Names
If Cell.Offset(, 1) = "Yes" Then
sheetArray(i) = Cell.value
i = i + 1
ElseIf Cell.Offset(, 1) = "No" Then
j = j + 1
End If
Next
''' Writes Macro text to new module ''''
temp_string = "Dim nm As Name" & vbNewLine & _
"Dim named_range As String" & vbNewLine & _
"Dim sheet_name As String" & vbNewLine & _
"Dim yes_column As Range" & vbNewLine & _
"Dim Cell As Range" & vbNewLine & _
"Dim Cell2 As Range" & vbNewLine & _
"Dim date_column As Range" & vbNewLine & _
"Dim Refresh_Sheets As Range" & vbNewLine & _
"Dim i As Long" & vbNewLine & "Application.ScreenUpdating = False" & vbNewLine & _
"x = 1" & vbNewLine & _
"y = 0" & vbNewLine & _
"Sheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Range(Range(" & Chr$(34) & "B4" & Chr$(34) & "), Range(" & Chr$(34) & "B4" & Chr$(34) & ").End(xlDown).End(xlDown)).Clear" & vbNewLine & _
"Sheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Range(Range(" & Chr$(34) & "E4" & Chr$(34) & ").End(xlDown), Range(" & Chr$(34) & "K4" & Chr$(34) & ")).Clear" & vbNewLine & _
"Sheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Range(" & Chr$(34) & "B4:R100" & Chr$(34) & ").Clear" & vbNewLine & _
"index = Sheets(" & Chr$(34) & "ESSBASE START ->" & Chr$(34) & ").index" & vbNewLine & _
"index_end = Sheets(" & Chr$(34) & "<- ESSBASE END" & Chr$(34) & ").index"
DestinationModule.AddFromString temp_string
''' Customizes macro to include user's selected retrieves ''''
For i = 1 To UBound(sheetArray) - j
temp_string = "Worksheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Range(" & Chr$(34) & "B" & Chr$(34) & " & 3 + " & i & ").value =" & Chr$(34) & sheetArray(i) & Chr$(34)
DestinationModule.AddFromString temp_string
Next
'''' finishes macro ''''
temp_string = "i = " & i - 2 & vbNewLine & "Set Refresh_Sheets = Range(" & Chr$(34) & "B4:B" & Chr$(34) & "& 4 + i)" & vbNewLine & _
"For Each Cell2 In Refresh_Sheets" & vbNewLine & _
" For Each nm In ActiveWorkbook.Names " & vbNewLine & " named_range = Right(nm.Name, Len(nm.Name) - InStr(nm.Name, " & Chr$(34) & "!" & Chr$(34) & "))" & vbNewLine & _
" sheet_name = Split(nm, " & Chr$(34) & "!" & Chr$(34) & ")(0)" & vbNewLine & _
" sheet_name = Split(sheet_name, " & Chr$(34) & "=" & Chr$(34) & ")(1)" & vbNewLine & " sheet_name = Replace(sheet_name, " & Chr$(34) & Chr$(39) & Chr$(34) & ", " & Chr$(34) & "" & Chr$(34) & ")" & vbNewLine & _
" If sheet_name = Worksheets(Cell2.value).Name And Left(named_range, 8) = " & Chr$(34) & "Retrieve" & Chr$(34) & " And nm.Visible = True Then " & vbNewLine & _
" Sheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Cells(3 + x, 5 + y) = named_range" & vbNewLine & " y = y + 1" & vbNewLine & _
" End If" & vbNewLine & " Next nm" & vbNewLine & _
" y = 0" & vbNewLine & " x = x + 1" & vbNewLine & "Next Cell2" & vbNewLine & _
"Set yes_column = Sheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Range(" & Chr$(34) & "C4:C100" & Chr$(34) & ")" & vbNewLine & _
"With yes_column.Validation" & vbNewLine & _
" .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=" & Chr$(34) & "Yes,No" & Chr$(34) & "" & vbNewLine & _
"End With" & vbNewLine & _
"For Each Cell In yes_column" & vbNewLine & _
" Cell.FormulaLocal = " & Chr$(34) & "=IF( OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -1) <> " & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & ", " & Chr$(34) & "" & Chr$(34) & "Yes" & Chr$(34) & "" & Chr$(34) & ", " & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & ") " & Chr$(34) & "" & vbNewLine & _
"Next" & vbNewLine & _
"Set date_column = Sheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Range(" & Chr$(34) & "D4:D100" & Chr$(34) & ")" & vbNewLine & _
"For Each Cell In date_column" & vbNewLine & _
" Cell.FormulaLocal = " & Chr$(34) & "=IFERROR(IF(INDEX(INDIRECT(" & Chr$(34) & "" & Chr$(34) & Chr$(39) & Chr$(34) & "" & Chr$(34) & "&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -2)&" & Chr$(34) & "" & Chr$(34) & Chr$(39) & "!" & Chr$(34) & "" & Chr$(34) & "&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, 1)), 2, 1)>0,INDEX(INDIRECT(" & Chr$(34) & "" & Chr$(34) & Chr$(39) & Chr$(34) & "" & Chr$(34) & "&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, -2)&" & Chr$(34) & "" & Chr$(34) & Chr$(39) & "!" & Chr$(34) & "" & Chr$(34) & "&@OFFSET( INDIRECT( ADDRESS( ROW(), COLUMN())), 0, 1)), 2, 1)," & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & "), " & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & "" & Chr$(34) & ")" & Chr$(34) & "" & vbNewLine & _
" Cell.NumberFormat = (" & Chr$(34) & "m/d/yyyy h:mm" & Chr$(34) & ")" & vbNewLine & _
"Next" & vbNewLine & _
"Sort_Refresh_Dashboard" & vbNewLine & _
"Worksheets(" & Chr$(34) & "Refresh Dashboard" & Chr$(34) & ").Activate" & vbNewLine & _
"Application.ScreenUpdating = True" & vbNewLine & _
"End Sub"
DestinationModule.AddFromString temp_string
temp_string = "Public Sub " & Macro_Name & "()" & vbNewLine
DestinationModule.InsertLines 1, temp_string
DestinationModule.ReplaceLine 3, ""
temp_string = "Option Compare Text"
DestinationModule.InsertLines 1, temp_string
''' Macro writing completed!'''
y = 0
'''' Creates button under Saved Retrieves: header and maps it to created macro """
NextButton:
For Each b In Worksheets("Refresh Dashboard").Buttons
If b.TopLeftCell.address = "$S$" & 12 + y Then
y = y + 3
GoTo NextButton
End If
Next
Set t = Worksheets("Refresh Dashboard").Range("S" & 12 + y & ":U" & 14 + y)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = Macro_Name & "." & Macro_Name
.Characters.Text = Macro_Name
.Name = Macro_Name
End With
Application.ScreenUpdating = True
End Sub
Riley Dunnaway 
Leave a comment