Function HLookup3D(LookupVal As Variant, LookupTable, nRow As Long, bExactMatch As Variant) As Variant
'Function works just like HLOOKUP function, except can handle 3-D cell range references
'LookupTable may be single sheet or multi-sheet references to a range of cells _
Enter 3-D ranges just like in a SUM formula: =HLookup3D("Profits",'Sheet 1:Sheet 3'!A1:H7, 2, False)
'LookupVal may be text or number
'Function returns the value from row nRow on first worksheet where there is a match for LookupVal
'Note: there must be only one HLookup3D function in a formula--the wrong answer will be returned if there is more than one.
Dim cel As Range
Dim iFirstCheck As Integer, iLastCheck As Integer, k As Integer
Dim vResults As Variant, vTable As Variant
Dim wbTable As Workbook
On Error Resume Next
Set cel = Application.Caller
If cel Is Nothing Then
HLookup3D = "#NoRange"
Exit Function
End If
vTable = Parse3D(cel.Cells(1), "HLookup3D", 2)
Set wbTable = Workbooks(vTable(0))
iFirstCheck = wbTable.Worksheets(vTable(1)).Index
iLastCheck = wbTable.Worksheets(vTable(2)).Index
If VarType(LookupTable) = 10 Then
For k = iFirstCheck To iLastCheck
vResults = Application.HLookup(LookupVal, wbTable.Worksheets(k).Range(vTable(3)), nRow, bExactMatch)
If Not IsError(vResults) Then Exit For
Next
Else
vResults = Application.HLookup(LookupVal, LookupTable, nRow, bExactMatch)
End If
HLookup3D = vResults
End Function
Private Function Parse3D(FormulaCell As Range, fnName As String, parmIndex As Integer) As Variant
'Parses a formula looking for a specified function. If found, returns a variant array containing four strings: _
workbook name, first worksheet name, last worksheet name and range address
'Function tolerates commas in workbook or sheet names, array constants and range unions
Dim i As Integer, i1 As Integer, i2 As Integer, i3 As Integer, j As Integer, k As Integer, n As Integer
Dim firstSheet As String, frmla As String, lastSheet As String, sPlaceHolder As String, sRange As String, _
sSeparator As String, sSheets As String, sWorkbook As String, s1 As String, s2 As String
Dim nm As Name
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
sSeparator = "," 'The .Formula property uses a comma as list separator, no matter what the regional setting
sPlaceHolder = "?" 'This can be any character not found in workbook or worksheet names
frmla = FormulaCell.Formula
j = InStr(1, UCase(frmla), UCase(fnName) & "(")
If j > 0 Then
sSheets = Mid(frmla, j + Len(fnName) + 1)
'Eliminate any list separators that might be embedded in the formula
For i = 0 To 4
s1 = Array("'", """", "(", "{", "[")(i)
s2 = Array("'", """", ")", "}", "]")(i)
i1 = InStr(1, sSheets, s1)
Do Until i1 = 0
i2 = InStr(i1 + 1, sSheets, s2)
If i <= 1 And Mid(sSheets, i2, 2) = (s1 & s1) Then i2 = InStr(i2 + 2, sSheets, s1)
If i2 > 0 Then
i3 = InStr(i1, sSheets, sSeparator)
Select Case i3
Case 0
Case Is < i2
sSheets = Left(sSheets, i1) & Replace(Mid(sSheets, i1 + 1, i2 - i1 - 1), sSeparator, sPlaceHolder) & Mid(sSheets, i2)
End Select
i1 = InStr(i2 + 1, sSheets, s1)
End If
Loop
Next
sSheets = Split(sSheets, sSeparator)(parmIndex - 1)
sSheets = Replace(sSheets, sPlaceHolder, sSeparator) 'Restore any list separators that had temporarily been replaced with splaceholder
If Right(sSheets, 1) = ")" Then sSheets = Left(sSheets, Len(sSheets) - 1)
'Test whether parameter is a named range
On Error Resume Next
Set nm = FormulaCell.Parent.Names(sSheets)
If nm Is Nothing Then Set nm = FormulaCell.Parent.Parent.Names(sSheets)
On Error GoTo 0
If Not nm Is Nothing Then sSheets = Mid(nm.RefersTo, 2) 'Delete the initial = sign
sSheets = Replace(sSheets, "''", "'") 'Single quotes embedded within sheet names are doubled up to escape them
k = InStrRev(sSheets, "!")
If k = 0 Then
sRange = sSheets
firstSheet = FormulaCell.Worksheet.Name
lastSheet = FormulaCell.Worksheet.Name
Else
sRange = Mid(sSheets, k + 1)
sSheets = Left(sSheets, k - 1)
k = InStr(1, sSheets, "]")
If k > 0 Then
sWorkbook = Split(sSheets, "]")(0)
If Left(sWorkbook, 1) = "'" Then sWorkbook = Mid(sWorkbook, 2)
If Left(sWorkbook, 1) = "[" Then sWorkbook = Mid(sWorkbook, 2)
sSheets = Split(sSheets, "]")(1)
End If
If Left(sSheets, 1) = "'" Then sSheets = Mid(sSheets, 2)
If Right(sSheets, 1) = "'" Then sSheets = Left(sSheets, Len(sSheets) - 1)
k = InStr(1, sSheets, ":")
If k = 0 Then
firstSheet = sSheets
lastSheet = sSheets
Else
firstSheet = Split(sSheets, ":")(0)
lastSheet = Split(sSheets, ":")(1)
End If
End If
If sWorkbook = "" Then sWorkbook = FormulaCell.Worksheet.Parent.Name
Parse3D = Array(sWorkbook, firstSheet, lastSheet, sRange)
End If
End Function
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
Excel file that does not ask to be saved before exiting | 6 | 23 | |
Request to review costing formula | 3 | 36 | |
Formula Help | 3 | 23 | |
Excel Formula: How to calculate days in any current year, from Jan 1 to the current date, using computer internal clock? | 7 | 18 |
Join the community of 500,000 technology professionals and ask your questions.