VBA to pull reference a different worksheet

[cgsierra]

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:

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

 

[Roderick_E]

2 potentials:

1) Make a "personal" macro and load it on everyone's computer, which would allow them to work with their individual companies using a single-tab workbook.
2) Have the "tool" macro part of this workbook be a separate workbook that the users can open and have it interact with the individual company workbooks.

 

[mumps]

You can use this code to open the raw data workbook:

Dim RawDataWB As Workbook
Set RawDataWB = Workbooks.Open("S:\Shared Folders\FP&A 7yr\07-CCS\Forecasts\2019\Management Month End Check Tools\Raw Data.xlsb")
Set wksData = Worksheets("Raw Data")

and then in appropriate place in your macro you can insert this line of code to close the workbook when you're finished with it

RawDataWB.Close False

I would also place these lines of code at the beginning and end of your macro:

Application.ScreenUpdating = False
'your code here
Application.ScreenUpdating = True

This will prevent screen flickering and speed up the macro.

 

[cgsierra]

You can use this code to open the raw data workbook:

Dim RawDataWB As Workbook
Set RawDataWB = Workbooks.Open("S:\Shared Folders\FP&A 7yr\07-CCS\Forecasts\2019\Management Month End Check Tools\Raw Data.xlsb")
Set wksData = Worksheets("Raw Data")

and then in appropriate place in your macro you can insert this line of code to close the workbook when you're finished with it

RawDataWB.Close False

I would also place these lines of code at the beginning and end of your macro:

Application.ScreenUpdating = False
'your code here
Application.ScreenUpdating = True

This will prevent screen flickering and speed up the macro.

Thank you both
I like the solution above. However, it seemed to work initially but it stopped afterwards. One thing I did not mention is that each of the 9 sheets that are populated with the information from the "Raw Data" tab has its own Macro button to run the VBA code I posted earlier. Each of the 9 sheets has input parameters to pull different info from the Raw Data tab. I would rather run the macro for all worksheets that have said parameters but that's another story. I'm not sure if the vba code stopped working after I ran the macro on the second of the 9 sheets
Below is my code once I add your suggestions. Any idea why it would stop running? Is it because the Raw Data file is already open once i run the macro for the second time (2nd worksheet of the 9 worksheets where the raw data is populated)? I would rather not close the Raw Data workbook after running the VBA in each of the 9 workdsheets because it takes too long to go through the process

Option Explicit


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
Dim RawDataWB As Workbook


Application.ScreenUpdating = False


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 RawDataWB = Workbooks.Open("S:\Shared Folders\FP&A 7yr\07-CCS\Forecasts\2019\Management Month End Check Tool\Raw Data.xlsb")
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("G344:G570")             ' 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 j = 3 Then
                MyParmData(3, k) = "145"
            End If
            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)


    'create a key with acct, month, year - this is for records that have an * for the Code (hierarchy)
    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
        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


                    ' 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
                    '                    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)) & "|" & MyAccts(acct, 3) & "|" & MyAccts(acct, 4)   'the value above the date, the SL (3) and the Code (4)


                    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


Application.ScreenUpdating = True


End Sub

 

[mumps]

Are you getting any error messages or warning messages? Is it necessary to run the macro for each sheet? Could you perhaps loop through the sheets and have the macro pull the data from the "Raw Data" sheet and populate all the sheets with one run?

 

[cgsierra]

Are you getting any error messages or warning messages? Is it necessary to run the macro for each sheet? Could you perhaps loop through the sheets and have the macro pull the data from the "Raw Data" sheet and populate all the sheets with one run?

I would love to be able to do that but I don't know how to. The challenge is that not all files need to be populated with the Raw Data info. Nontheless, I could place an "x" in cell L1 as an example to mark the worksheet so it is not be populated with the Raw Data info. But again, i dont know how to write that code. This is an existing code which I am trying to adjust to meet new business needs.

No error messages, it just continues to run (longest I left it was for 10 minutes before stopping it...with the Raw Data tab inside the same file, it takes 2 seconds to populate the data in each worksheets)

 

[mumps]

What is the actual name of wksReport sheet? I'll see if I can come up with something that will allow you to do all sheet in one run. You could put an "x" in L1 to mark it or if the sheet names you want populated are always the same, you can post those sheets names here and they can be put into an array that the macro can read.

 

[cgsierra]

What is the actual name of wksReport sheet? I'll see if I can come up with something that will allow you to do all sheet in one run. You could put an "x" in L1 to mark it or if the sheet names you want populated are always the same, you can post those sheets names here and they can be put into an array that the macro can read.

I would really appreciate that! the wksReport sheet is set to ActiveSheet because each worksheet where I run the macro has a different name (like 8 names/tabs in totals). In addition, the same VBA is used in other workbooks for other companies and the tabs in those workbooks also have different names. IE. Out of the 15 tabs in workbook "Month End Check Dashboard-Apr 2019.xlsb", I run the VBA in about 8 tabs (TN, TA, BO, WF, ODC, etc). The same VBA is used in workbook "Month End Check Dashboard-Apr 2019.xlsb-PD" where the tabs names are (SE, NW, IT, HR, TE, etc). There are mutliple companies and each company has mutliple tabs and all tabs have different names. Next month, the workbook names will change to Month End....May 2019.xlsb.

 

[mumps]

It actually doesn't matter what the sheet names are if all the sheets in all the companies' workbooks have to be updated. Is this the case?

 

[cgsierra]

It actually doesn't matter what the sheet names are if all the sheets in all the companies' workbooks have to be updated. Is this the case?

No, unfortunately some tabs have to be updated but some others don’t. The tabs would have to be identified with something like an “x” in a specific spot so it’s not updated