R
Regan
I am trying to create a customied funtion in XL. But
things aren't working to plan.... Here's the stats...
I have a spreadsheet that looks like this (with the first
row being headers)
Path Spec Cy Sheet Range
D:\Test 123 ABC sheet1 skimmilk
I would like to write a function for column F similar to
the following
=DataValue(a2,b2,c2,d2,e2)
Simple enough I thought, so I composed the code below
where I open another w/book as specified in the paramaters
and retreive the value. (This will open a workbook on each
calculation, but I happy with this performance hit.)
BUT IT DOESN'T WORK. It does work when called from a
subroutine. but not from a function !!!!! - Why is this??
(the sub routine "SubDataValue" works- pasted at the end
of this post - this essentially mimics what the formular
=DataValue(a2,b2,c2,d2,e2) would do on calculation.
Can anyone offer any insite??
Option Explicit
Option Compare Text
'****************
Function DataValue(strPath As String, strSpec As String,
strCypher As String, _
strSHeet As String, strRange As String)
'purpose = to retrive a specific cell from another w/book
'On Error GoTo DataValue_err
Dim strFilePath As String
Dim strFileName As String
strFileName = strSpec & strCypher & ".xls"
strFilePath = strPath & "\" & strFileName
If OpenBook(strFilePath) = True Then
'get the datavalue
DataValue = Workbooks(strFileName).Sheets
(strSHeet).Range(strRange).Value
Else
MsgBox "cannot find the file: " & strFilePath
End If
Exit Function
DataValue_err:
MsgBox Err.Number & " " & Err.Description
End Function
'****************
Function OpenBook(strFilePath As String) As Boolean
' This procedure checks to see if the workbook
' specified in the strFilePath argument is open.
' If it is open, the workbook is activated. If it is
' not open, the procedure opens it.
Dim wkbCurrent As Excel.Workbook
Dim strBookName As String
On Error GoTo OpenBook_Err
' Determine the name portion of the strFilePath
argument.
strBookName = NameFromPath(strFilePath)
If Len(strBookName) = 0 Then Exit Function
If Workbooks.Count > 0 Then
For Each wkbCurrent In Workbooks
If UCase$(wkbCurrent.Name) =
UCase$(strBookName) Then
OpenBook = True
'wkbCurrent.Activate
Exit Function
End If
Next wkbCurrent
End If
Workbooks.Open strFilePath, , True
OpenBook = True
OpenBook_End:
Exit Function
OpenBook_Err:
OpenBook = False
Resume OpenBook_End
End Function
'*****************
Function NameFromPath(strPath As String) As String
' This procedure takes a file path and returns
' the file name portion.
Dim lngPos As Long
Dim strPart As String
Dim blnIncludesFile As Boolean
' Check that this is a file path.
' Find the last path separator.
lngPos = InStrRev(strPath, "\")
' Determine if string after last backslash
' contains a period.
blnIncludesFile = InStrRev(strPath, ".") > lngPos
strPart = ""
If lngPos > 0 Then
If blnIncludesFile Then
strPart = Right$(strPath, Len(strPath) -
lngPos)
End If
End If
NameFromPath = strPart
End Function
'********
Sub SubDataValue()
Dim strFilePath As String
Dim strSHeet
Dim strRange
Dim strFileName
strFileName = "readbook.xls"
strFilePath = "D:\Test\readbook.xls"
strSHeet = "sheet1"
strRange = "Skimmilk"
If OpenBook(strFilePath) = True Then
'get the datavalue
MsgBox Workbooks(strFileName).Sheets(strSHeet).Range
(strRange).Value
End If
End Sub
things aren't working to plan.... Here's the stats...
I have a spreadsheet that looks like this (with the first
row being headers)
Path Spec Cy Sheet Range
D:\Test 123 ABC sheet1 skimmilk
I would like to write a function for column F similar to
the following
=DataValue(a2,b2,c2,d2,e2)
Simple enough I thought, so I composed the code below
where I open another w/book as specified in the paramaters
and retreive the value. (This will open a workbook on each
calculation, but I happy with this performance hit.)
BUT IT DOESN'T WORK. It does work when called from a
subroutine. but not from a function !!!!! - Why is this??
(the sub routine "SubDataValue" works- pasted at the end
of this post - this essentially mimics what the formular
=DataValue(a2,b2,c2,d2,e2) would do on calculation.
Can anyone offer any insite??
Option Explicit
Option Compare Text
'****************
Function DataValue(strPath As String, strSpec As String,
strCypher As String, _
strSHeet As String, strRange As String)
'purpose = to retrive a specific cell from another w/book
'On Error GoTo DataValue_err
Dim strFilePath As String
Dim strFileName As String
strFileName = strSpec & strCypher & ".xls"
strFilePath = strPath & "\" & strFileName
If OpenBook(strFilePath) = True Then
'get the datavalue
DataValue = Workbooks(strFileName).Sheets
(strSHeet).Range(strRange).Value
Else
MsgBox "cannot find the file: " & strFilePath
End If
Exit Function
DataValue_err:
MsgBox Err.Number & " " & Err.Description
End Function
'****************
Function OpenBook(strFilePath As String) As Boolean
' This procedure checks to see if the workbook
' specified in the strFilePath argument is open.
' If it is open, the workbook is activated. If it is
' not open, the procedure opens it.
Dim wkbCurrent As Excel.Workbook
Dim strBookName As String
On Error GoTo OpenBook_Err
' Determine the name portion of the strFilePath
argument.
strBookName = NameFromPath(strFilePath)
If Len(strBookName) = 0 Then Exit Function
If Workbooks.Count > 0 Then
For Each wkbCurrent In Workbooks
If UCase$(wkbCurrent.Name) =
UCase$(strBookName) Then
OpenBook = True
'wkbCurrent.Activate
Exit Function
End If
Next wkbCurrent
End If
Workbooks.Open strFilePath, , True
OpenBook = True
OpenBook_End:
Exit Function
OpenBook_Err:
OpenBook = False
Resume OpenBook_End
End Function
'*****************
Function NameFromPath(strPath As String) As String
' This procedure takes a file path and returns
' the file name portion.
Dim lngPos As Long
Dim strPart As String
Dim blnIncludesFile As Boolean
' Check that this is a file path.
' Find the last path separator.
lngPos = InStrRev(strPath, "\")
' Determine if string after last backslash
' contains a period.
blnIncludesFile = InStrRev(strPath, ".") > lngPos
strPart = ""
If lngPos > 0 Then
If blnIncludesFile Then
strPart = Right$(strPath, Len(strPath) -
lngPos)
End If
End If
NameFromPath = strPart
End Function
'********
Sub SubDataValue()
Dim strFilePath As String
Dim strSHeet
Dim strRange
Dim strFileName
strFileName = "readbook.xls"
strFilePath = "D:\Test\readbook.xls"
strSHeet = "sheet1"
strRange = "Skimmilk"
If OpenBook(strFilePath) = True Then
'get the datavalue
MsgBox Workbooks(strFileName).Sheets(strSHeet).Range
(strRange).Value
End If
End Sub