Function pull(xref As String) As Variant
'inspired by Bob Phillips and Laurent Longre
'but written by Harlan Grove
'-----------------------------------------------------------------
'Copyright (c) 2003 Harlan Grove.
'
'This code is free software; you can redistribute it and/or modify
'it under the terms of the GNU General Public License as published
'by the Free Software Foundation; either version 2 of the License,
'or (at your option) any later version.
'-----------------------------------------------------------------
'2005-05-02
'fixed InStrRev syntax. Now using XL2K+ syntax.
'-----------------------------------------------------------------
'2005-04-18
'added logic to check for date values from open workbooks, then
'adjust for 1904 date system in source workbooks
'-----------------------------------------------------------------
'2004-05-30
'still more fixes, this time to address apparent differences between
'XL8/97 and later versions. Specifically, fixed the InStrRev call,
'which is fubar in later versions and was using my own hacked version
'under XL8/97 which was using the wrong argument syntax. Also either
'XL8/97 didn't choke on CStr(pull) called when pull referred to an
'array while later versions do, or I never tested the 2004-03-25 fix
'against multiple cell references.
'-----------------------------------------------------------------
'2004-05-28
'fixed the previous fix - replaced all instances of 'expr' with
''xref' also now checking for initial single quote in xref, and if
'found advancing past it to get the full pathname [really dumb!]
'-----------------------------------------------------------------
'2004-03-25
'revised to check if filename in xref exists - if it does, proceed;
'otherwise, return a #REF! error immediately - this avoids Excel
'displaying dialogs when the referenced file doesn't exist
'-----------------------------------------------------------------
Const DS1904DIFF As Long = 1461
Dim xlapp As Object, xlwb As Workbook
Dim b As String, r As Range, c As Range, n As Long, ds1904 As Boolean
'** begin 2004-05-30 changes **
'** begin 2004-05-28 changes **
'** begin 2004-03-25 changes **
'** 2005-05-02 change - XL2K+ syntax **
n = InStrRev((xref), "\")
If n > 0 Then
If Mid(xref, n, 2) = "\[" Then
b = Left(xref, n)
n = InStr(n + 2, xref, "]") - n - 2
If n > 0 Then b = b & Mid(xref, Len(b) + 2, n)
Else
'** 2005-05-02 change - XL2K+ syntax **
n = InStrRev((xref), "!")
If n > 0 Then b = Left(xref, n - 1)
End If
'** key 2004-05-28 addition **
If Left(b, 1) = "'" Then b = Mid(b, 2)
On Error Resume Next
If n > 0 Then If Dir(b) = "" Then n = 0
Err.Clear
On Error Goto 0
End If
If n <= 0 Then
pull = CVErr(xlErrRef)
Exit Function
End If
'** end 2004-03-25 changes **
'** end 2004-05-28 changes **
pull = Evaluate(xref)
'** begin 2005-04-18 changes **
If Not IsError(pull) Then
On Error Resume Next
ds1904 = Workbooks(Right(b, n)).Date1904
Err.Clear
On Error Goto 0
End If
'** key 2004-05-30 addition **
'** changed in 2005-04-18 changes **
If IsArray(pull) Then
If ds1904 Then
Dim a As Variant, i As Long, j As Long
a = pull
For i = LBound(a, 1) To UBound(a, 1)
For j = LBound(a, 2) To UBound(a, 2)
If VarType(a(i, j)) = vbDate Then _
a(i, j) = a(i, j) + DS1904DIFF
Next j
Next i
pull = a
End If
Exit Function
ElseIf ds1904 And VarType(pull) = vbDate Then
pull = pull + DS1904DIFF
End If
'** end 2004-05-30 changes **
'** end 2005-04-18 changes **
If CStr(pull) = CStr(CVErr(xlErrRef)) Then
On Error Goto CleanUp 'immediate clean-up at this point
Set xlapp = CreateObject("Excel.Application")
Set xlwb = xlapp.Workbooks.Add 'needed by .ExecuteExcel4Macro
On Error Resume Next 'now clean-up can wait
n = InStr(InStr(1, xref, "]") + 1, xref, "!")
b = Mid(xref, 1, n)
Set r = xlwb.Sheets(1).Range(Mid(xref, n + 1))
If r Is Nothing Then
pull = xlapp.ExecuteExcel4Macro(xref)
Else
For Each c In r
c.Value = xlapp.ExecuteExcel4Macro(b & c.Address(1, 1, xlR1C1))
Next c
pull = r.Value
End If
CleanUp:
If Not xlwb Is Nothing Then xlwb.Close 0
If Not xlapp Is Nothing Then xlapp.Quit
Set xlapp = Nothing
End If
End Function
'** 2005-05-02 change - InStrRev for XL97 using abbreviated XL2K+ syntax
#If Not VBA6 Then
Private Function InStrRev(s As String, ss As String) As Long
Dim k As Long, n As Long
k = Len(ss)
n = Len(s) - k + 1
For n = n To 1 Step -1
If Mid(s, n, k) = ss Then Exit For
Next n
InStrRev = n
End Function
#End If
'----- end VBA -----
