Hello,
I have a workbook that has a VBA code. I use this workbook for company ABC and my coworkers use it for many other companies. There are like 5 iterations of this workbook. Each workbook has about 10 worksheets, including a "Raw Data" tab. The VBA code in each workbook essentially extracts data from the "Raw Data" tab and populates the info on the other 9 worksheets. I want to centralize the "Raw Data" worksheet in a separate workbook as the "Raw Data" tabs for all companies are exactly the same and it contains a lot of rows making each file very heavy.
Is there a way to run the VBA in each company file so that it accesses/references the information located in the separate centralized file without having to open the centralized file?
The path to the centralized file is the following:
S:\Shared Folders\FP&A 7yr\07-CCS\Forecasts\2019\Management Month End Check Tools\Raw Data.xlsb, the tab name is "Raw Data"
The current VBA code is as follows:
I have a workbook that has a VBA code. I use this workbook for company ABC and my coworkers use it for many other companies. There are like 5 iterations of this workbook. Each workbook has about 10 worksheets, including a "Raw Data" tab. The VBA code in each workbook essentially extracts data from the "Raw Data" tab and populates the info on the other 9 worksheets. I want to centralize the "Raw Data" worksheet in a separate workbook as the "Raw Data" tabs for all companies are exactly the same and it contains a lot of rows making each file very heavy.
Is there a way to run the VBA in each company file so that it accesses/references the information located in the separate centralized file without having to open the centralized file?
The path to the centralized file is the following:
S:\Shared Folders\FP&A 7yr\07-CCS\Forecasts\2019\Management Month End Check Tools\Raw Data.xlsb, the tab name is "Raw Data"
The current VBA code is as follows:
Code:
Option Explicit
Global Const Troubleshooting_Mode = False 'toggles troubleshooting options
Sub AddEmUp()
Dim wksReport As Worksheet, wksData As Worksheet
Dim MyTable As Range, myDates As Range
Dim MyParmCols As Variant, MyAccts As Range, DateCols As Variant
Dim MyData As Variant, MyParmData As Variant, mdate As Variant, mycell As Variant
Dim arrAccts
Dim MyFilter As Object, WildCardFilter As Object
Dim i As Long, j As Long, k As Long, acc As Long, c As Long
Dim d1 As String, errMessage As String, d2 As String
Dim cAppState As clsAppState
Dim acct As Long
Dim ResultsArray
Dim counter As Integer, FirstColumn As Integer
Dim bCurrentArray As Boolean, bResetArray As Boolean
Dim CodeCollection As Collection
Dim SplitCodes
If Not Troubleshooting_Mode Then
On Error GoTo ErrHandler 'general error handling
'turns off functionality that slows programs down
Set cAppState = New clsAppState
cAppState.SetState None
End If
'setting some sheet objects
Set wksData = Worksheets("Raw Data")
Set wksReport = ActiveSheet
' Define parameters
Set MyTable = wksData.Range("A1:M1") ' Define top row of the data table, the macro figures -
' out the bottom row based on the last non-empty cell in A
' Read the "Raw Data"
MyData = MyTable.Resize(MyTable.Resize(1, 1).Offset(Rows.Count - 1).End(xlUp).Row)
With wksReport
'if you use 'Set' - then you're just assigning the object to a range
'if you remove the 'Set' then you are placing the range into an array and into memory
Set MyAccts = .Range("G14:J343") ' This should be the column where the accounts are -
' set the rows to first row with an account to the -
' last row with an account, empty cells will be ignored
' expand to include the columns with the additional information to include (SL and/or Code)
arrAccts = MyAccts 'put range into memory
Set myDates = .Range("M12:p12, AF12:Aq12, AY12:BJ12, BR12:CC12, ck12:cv12, dd12:do12") ' Set this to the cells with the dates, if there are gaps, -
' define the ranges as shown. The "ACTUALS" or "BUDGET" -
' row is assumed to be above this row
' The parameters - can be an actual parameter or a "*" to mean -
' match anything - no other wildcards are supported
' Read the parms
MyParmData = .Range("L2:O7")
End With
MyParmCols = Array(1, 2, 3, 4, 5, 6) ' The columns that the parameters relate to - in this example, -
' the parameters on row 2 match column 1 (A) on the "Raw Data" -
' sheet, row 3 matches column 2, row 4 matches column 3, row 5 -
' matches nothing (0), etc.
'Put Date columns into array
'doing this to speed things up
ReDim DateCols(1 To myDates.Count) 'creating an array to fit the column numbers
For Each mycell In myDates
i = i + 1
DateCols(i) = mycell.Column
Next mycell
' Create a dictionary to put the totals in
Set MyFilter = CreateObject("Scripting.Dictionary")
Set WildCardFilter = CreateObject("Scripting.Dictionary")
' Read through the raw data, selecting the rows that match the parameters
For i = 1 To UBound(MyData)
For j = 1 To UBound(MyParmData)
If MyParmCols(j - 1) = 0 Then
GoTo NextJ
End If
For k = 1 To 4
If MyData(i, MyParmCols(j - 1)) = MyParmData(j, k) Or MyParmData(j, k) = "*" Then
GoTo NextJ
End If
Next k
GoTo NextI:
NextJ:
Next j
' Found a match on all parameters, create a key with the acct, month, year, and type,then add up the total
d1 = CLng(MyData(i, 7)) & "|" & MyData(i, 9) & "|" & MyData(i, 10) & "|" & LCase(MyData(i, 12)) & "|" & CLng(MyData(i, 13))
MyFilter(d1) = MyFilter(d1) + MyData(i, 11)
d2 = CLng(MyData(i, 7)) & "|" & MyData(i, 9) & "|" & MyData(i, 10) & "|" & LCase(MyData(i, 12))
WildCardFilter(d2) = WildCardFilter(d2) + MyData(i, 11)
NextI:
Next i
counter = 1
' All totals found, now read through all the accounts/dates on the output sheet and place the totals
' code loops through the columns for each row
With wksReport
For acct = 1 To UBound(arrAccts) 'loop through each row in the array
' If acct = 132 Then Stop 'test line
If Len(Trim(arrAccts(acct, 1))) > 0 Then
acc = Trim(arrAccts(acct, 1)) 'place the Acct value in the array into a variable
If acc <> 0 Then ' ignore empty cells in the Accounts column
For mdate = 1 To UBound(DateCols) 'loop through the Date columns
Set CodeCollection = New Collection 'reset the collection
'if there's a comma in column J (MyAccts(acct,4), then split it into an array and loop through the values
'if there's an * in the column, won't do split
'either way, results are added to the collection
'If acct = 132 And mdate = 37 Then Stop 'test line
' Make a key with the account, month, year, and type, and read the total from the dictionary
' we're looking up the information on the sheet using variables in memory
If InStr(MyAccts(acct, 4), "*") = 0 Then 'looks in cell for *, if found, skips
SplitCodes = Split(MyAccts(acct, 4), ",")
For c = LBound(SplitCodes) To UBound(SplitCodes)
d1 = CLng(acc) & "|" & Month(.Cells(myDates(1, 1).Row, DateCols(mdate)).Value) & "|" & Year(.Cells(myDates(1, 1).Row, DateCols(mdate)).Value) & _
"|" & LCase(CStr(.Cells(myDates(1, 1).Row, DateCols(mdate)).Offset(-1).Value)) & "|" & Trim(SplitCodes(c)) 'the value above the date and the Code
CodeCollection.Add d1 'add the key to the collection
Next c
Else
d1 = CLng(acc) & "|" & Month(.Cells(myDates(1, 1).Row, DateCols(mdate)).Value) & "|" & Year(.Cells(myDates(1, 1).Row, DateCols(mdate)).Value) & _
"|" & LCase(CStr(.Cells(myDates(1, 1).Row, DateCols(mdate)).Offset(-1).Value)) 'the value above the date
CodeCollection.Add d1
End If
'because the data is not consecutive by row or columns,
'I have to write short arrays to the sheet.
'logic to figure out if i need to create a fresh array or continue to populate the current
If mdate = 1 Then
bCurrentArray = True
ElseIf DateCols(mdate) = DateCols(mdate - 1) + 1 Then
bCurrentArray = True
Else
bCurrentArray = False
End If
'handles the array
If bCurrentArray Then
If Not IsArray(ResultsArray) Or bResetArray Then
'start a new array
FirstColumn = DateCols(mdate)
ReDim ResultsArray(1 To 1)
bResetArray = False
Else 'continue to use the current array
ReDim Preserve ResultsArray(1 To UBound(ResultsArray) + 1)
End If
Else
'dump the current array for the row & columns
'it's dumping the array for the previous set of dates
.Cells(MyAccts(1, 1).Offset(acct - 1).Row, FirstColumn).Resize(, UBound(ResultsArray)).Value = ResultsArray
'and start a new array
FirstColumn = DateCols(mdate)
ReDim ResultsArray(1 To 1)
bResetArray = False
End If
'loop through the collection of lookups and sum the returned values
'since * codes only allow for a single return values, there is no summing
For c = 1 To CodeCollection.Count
If MyAccts(acct, 4) <> "*" Then
If IsEmpty(MyFilter(CodeCollection(c))) Then
ResultsArray(UBound(ResultsArray)) = ResultsArray(UBound(ResultsArray)) + 0
Else
ResultsArray(UBound(ResultsArray)) = ResultsArray(UBound(ResultsArray)) + MyFilter(CodeCollection(c))
End If
Else 'is a * code, so no summing
If IsEmpty(WildCardFilter(CodeCollection(c))) Then
ResultsArray(UBound(ResultsArray)) = 0
Else
ResultsArray(UBound(ResultsArray)) = WildCardFilter(CodeCollection(c))
End If
End If
Next c
Next mdate
End If
bResetArray = True
'dump the last set of dates for the row
.Cells(MyAccts(1, 1).Offset(acct - 1).Row, FirstColumn).Resize(, UBound(ResultsArray)).Value = ResultsArray
End If
Next acct
End With
ErrHandler:
If Err.Number <> 0 Then
errMessage = errMessage & Chr(10) & "Module3.AddEmUp = " & Err.Number & ": " & Err.Description
End If
If Len(errMessage) > 0 Then
MsgBox errMessage, vbInformation, "Unable to continue"
End If
Set cAppState = Nothing 'reset all the settings
Call Module4.AddEmUp
End Sub
Last edited:
