View Single Post
  #7   Report Post  
Harlan Grove
 
Posts: n/a
Default

I think the problem is that I haven't updated the file on my ftp site with
the latest version of pull. Here's the latest version.


'----- begin VBA -----
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 -----