Looping vlookup through predefined named range in multiple sheets - excel

Question

So I've been solving this problem of mine for a couple days already.
Basically, I have multiple green sheets (my source sheets) and one main sheet (master sheet), the problem I'm working on has to do with looping through these green sheets in order to pull certain information from them and put it on certain columns in my master sheet.
Here's the layout of one of these green sheets for better understanding:
https://imgur.com/cayZXUA
I'm sorry for the links, cant add images yet
You can see that these green sheets consist of multiple boxes which can differ in size from sheet to sheet. Some of the values I need to retrieve are fixed in the same cell address for all green sheets so I have no problem getting them to the master sheet. But there are some cases like this:
https://imgur.com/nPYyLbM
Assumption box contains information that I need to lookup and pull it to Main sheet. In essence, this box can take up vertically any space so that address for values of payroll, tax and miscellaneous expenditures changes.
I came up with the idea of giving these boxes in all green sheets name "Assumptions" like seen in the image above. So the questions is how do I lookup 3rd column of this named box and pull it to main sheet?
Here's Main sheet structure:
https://imgur.com/CWMpGvH
My code so far:
Sub CombiningSheets()
Dim p_value, cst_value, m_value As Long
Dim p, cst, m As String
p = "payroll"
cst = "consolidated social tax"
m = "miscellaneous expenditures"
With ThisWorkbook.Sheets("Main")
For Each wsheet In ThisWorkbook.Sheets
If wsheet.Name <> "Main" Then
Set nextEntry = .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)
Set nextEntry_FTE_quantity = .Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0)
Set nextEntry_nonrecurring_expenses = .Cells(.Rows.Count, "S").End(xlUp).Offset(1, 0)
Set nextEntry_initiative_type = .Cells(.Rows.Count, "Q").End(xlUp).Offset(1, 0)
Set nextEntry_initiative_description = .Cells(.Rows.Count, "E").End(xlUp).Offset(1, 0)
Set nextEntry_economic_benefit = .Cells(.Rows.Count, "AA").End(xlUp).Offset(1, 0)
Set nextEntry_payroll = .Cells(.Rows.Count, "AI").End(xlUp).Offset(1, 0)
Set nextEntry_consolidated_social_tax = .Cells(.Rows.Count, "AJ").End(xlUp).Offset(1, 0)
Set nextEntry_miscellaneous_expenditures = .Cells(.Rows.Count, "AK").End(xlUp).Offset(1, 0)
If IsError(Application.Match(wsheet.Name, .Range("G:G"), 0)) Then
nextEntry.Value = wsheet.Name
nextEntry_initiative_description.Value = wsheet.Range("K6").Value
nextEntry_FTE_quantity.Value = wsheet.Range("BH16").Value
nextEntry_initiative_type.Value = wsheet.Range("K8").Value
nextEntry_nonrecurring_expenses.Value = wsheet.Range("BH17").Value
nextEntry_economic_benefit.Value = wsheet.Range("BH15").Value
End If
End If
Debug.Print wsheet.Name
Next wsheet
End With
End Sub

Answer 1

From your questions it seems that you have defined named ranges. As I'm aware of your question How to copy sheets with certain tab color from one workbook to another? I do believe that you don't have named ranges on your individual sheets.
Below you find some code if you have named ranges (Sub List_NamedRange_Loop).If you don't have named ranges you can create these named ranges on the individual sheets first (Sub Create_NamedRange).
At the end of this post you find a screenshot of the result I got.
Sub List_NamedRange_Loop()
Dim NamedRange As Name
Dim ws As Worksheet
Dim PrDebug As Boolean
Dim iCt As Integer
PrDebug = False ' => Output to Worksheet "Main"
'PrDebug = True ' => Output to Immediate Window (Ctrl-G in VBE)
'List on sheet "main"
If Not (PrDebug) Then
On Error Resume Next
Debug.Print ActiveWorkbook.Name
Sheets("main").Activate
If ActiveSheet.Name <> "main" Then
Worksheets.Add
ActiveSheet.Name = "main"
End If
On Error GoTo 0
Range("A1:D1000").ClearContents
Range("A1").Value = "Sheet Name"
Range("B1").Value = "Named Range"
Range("C1").Value = "RefersTo"
Range("D1").Value = "Value (Direct Reference)"
Range("E1").Value = "Value (Named Reference)"
End If
'We expect all named ranges to be local = defined on the indivdual sheets
'so no need for the below 'workbook loop'
'Loop through each named range in workbook
' For Each namedrange In ActiveWorkbook.Names
' Debug.Print namedrange.Name, namedrange.RefersTo
' Next namedrange
'Loop through each named range scoped to a specific worksheet
iCt = 0
For Each ws In Worksheets
iCt = iCt + 1
If ws.Names.Count > 0 Then
If PrDebug Then
Debug.Print
Debug.Print ws.Name
Else
End If
For Each NamedRange In ws.Names 'Worksheets("Sheet1").Names
If PrDebug Then
Debug.Print ws.Name, NamedRange.Name, NamedRange.RefersTo
Else
iCt = iCt + 1
Range("A1").Offset(iCt, 0).Value = ws.Name
' Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, ws.Name & "!", "")
If InStr(1, NamedRange.Name, "'") Then
Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, "'" & ws.Name & "'!", "")
Else
Range("B1").Offset(iCt, 0).Value = Replace(NamedRange.Name, ws.Name & "!", "")
End If
Range("C1").Offset(iCt, 0).Value = "'" & NamedRange.RefersTo
Range("D1").Offset(iCt, 0).Value = NamedRange.RefersTo
Range("E1").Offset(iCt, 0).Formula = "=" & NamedRange.Name
Range("E1").Offset(iCt, 0).Calculate
End If
Next NamedRange
Else
' iCt = iCt + 1
' Range("A1").Offset(iCt, 0).Value = ws.Name
' Range("B1").Offset(iCt, 0).Value = "NO NAMES DEFINED!"
End If
Next ws
End Sub
If you don't have named ranges you might create them with the code similar to the following:
Sub Create_NamedRange()
Dim ws As Worksheet
Dim foundRange As Range
For Each ws In Worksheets
If ws.Name <> "main" Then
Debug.Print ws.Name
Set foundRange = ws.Cells.Find(What:="payroll", After:=ActiveCell, LookIn:=xlValues, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
True, SearchFormat:=False)
If Not (foundRange Is Nothing) Then
Debug.Print "Found: "; ws.Name
'offset between AR and BH: 16 columns (https://imgur.com/nPYyLbM)
ws.Names.Add Name:="payroll", RefersTo:=foundRange.Offset(0, 16)
ws.Names.Add Name:="consolidated_social_tax", RefersTo:=foundRange.Offset(1, 16)
ws.Names.Add Name:="miscellaneous_expenditures", RefersTo:=foundRange.Offset(2, 16)
End If
End If
Next ws
End Sub

Answer 2

I would use Range.Find to locate the cells by keywords and return the values adjacent to them.
Sub TestFind()
Dim colOffset As Long
Dim wsheet As Worksheet
colOffset = Columns("BH").Column - Columns("AR").Column - 2 'Two Extra Cells in Merged Range Adjustment
For Each wsheet In ThisWorkbook.Worksheets
If wsheet.Name <> "Main" Then
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR"), "payroll", 0, colOffset)
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR"), "social tax", 0, colOffset)
Debug.Print FindValueRelativeToSearch(wsheet.Columns("AR:AT"), "miscellaneous expenditures", 0, colOffset)
End If
Next
End Sub
Function FindValueRelativeToSearch(SearchRange As Range, search As String, rowOffset As Long, colOffset As Long) As Variant
Dim cell As Range
Application.FindFormat.MergeCells = True
With SearchRange
Set cell = .Find(What:=search, After:=.Cells(1, 1), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=True)
End With
cell.Offset(rowOffset, colOffset).Activate
If cell Is Nothing Then
Debug.Print "Search not found: FindValueRelativeToSearch()", SearchRange.Address(0, 0, xlA1, True), search
Else
FindValueRelativeToSearch = cell.Offset(rowOffset, colOffset).Value
End If
End Function