Excel VBA UDF 立即执行 Window，在工作表上失败
Excel VBA UDF Executes in Immediate Window, Fails on Worksheet
UDF "NAV()" 旨在根据第一个参数（始终是日期）在网络驱动器上找到正确的报告，然后遍历所有工作表以找到与第二个相同行的数据参数和与第三个参数相同的列（第二个和第三个可以是文本或数字）。
立即可靠地工作window。总是 returns #VALUE！在工作表上使用时，例如=NAV(D7,D8,D9) 或 =NAV(2/19/2016,"Net Asset Value","221-I").
一般来说，如果试图改变 UDF 中的其他单元格，看起来可能会出现这种行为，但我的函数不会那样做。另外，我相信所有范围引用都指定了哪个工作簿和工作表，所以我认为这也不是问题所在。我不确定下一步要看哪里。
当找不到用户正在查找的内容时，该功能还会尝试通过 Outlook 通过电子邮件向我发送报告。我不知道这是否相关。
同样，令人困惑的是这段代码似乎立即可以正常工作 window，但只给出 #VALUE！在工作表上使用时。
我还可以在下面的代码中查看其他什么地方来确定什么会导致 NAV() 立即正确运行 window，但总是产生 #VALUE！什么时候用在工作表上？
Option Explicit
Function NAV(ByVal NAVDate As Date, ByVal matchRow As Variant, ByVal matchColumn As Variant) As Variant
'Application.ScreenUpdating = False
Application.Volatile True
NAV = FindItemOnWorksheet(NAVDate, matchRow, matchColumn)
'Application.ScreenUpdating = True
End Function
Function FindItemOnWorksheet(ByVal NAVDate As Date, ByVal ItemSpecies As Variant, ByVal ItemGenus As Variant) As Variant
' Finds Item by opening NAV workbook with correct date, activating correct worksheet, and searching for correct row and column
Dim startingRange As Range
Dim ws As Worksheet
Dim wb As Workbook
Dim theDate As Date
Dim theItemSpecies As String
Dim theItemGenus As String
theDate = NAVDate
theItemSpecies = ItemSpecies
theItemGenus = ItemGenus
Set wb = GetWB(NAVDate)
'Loop through ws
Dim WS_Count As Integer
Dim i As Integer
WS_Count = wb.Worksheets.Count
For i = 1 To WS_Count
Set ws = wb.Worksheets(i)
Set startingRange = ws.Range("A1:Z100")
Dim theRow As Range
Dim theColumn As Range
Set theRow = startingRange.Cells.Find(theItemSpecies, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theRow Is Nothing) Then
Set theColumn = startingRange.Cells.Find(theItemGenus, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theColumn Is Nothing) Then
FindItemOnWorksheet = ws.Cells(theRow.Row, theColumn.Column).Value
wb.Close
Exit Function
End If
End If
Next i
'Loop if no hit on either row or column Find()
'following executes only if no match found
MsgBox "No Match Found. Make sure you are entering arguments--" & vbNewLine & _
" The Date of NAV, " & vbNewLine & _
" the entry found in the right row of NAV workbooks (e.g. 'Net Asset Value'), " & vbNewLine & _
" the right column (e.g. 'Fund')." & vbNewLine & _
" This function will only find exact matches." & vbNewLine & vbNewLine & _
"Now emailing developer to ask for a fix."
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "User attempted" & _
"=FindItemOnWorksheet( " & theDate & ", " & theItemSpecies & ", " & theItemGenus & " )" & vbNewLine & _
"theDate type " & TypeName(theDate) & vbNewLine & _
"theItemSpecies type " & TypeName(theItemSpecies) & vbNewLine & _
"theItemGenus type " & TypeName(theItemGenus)
On Error Resume Next
With OutMail
.To = <Address Removed>
.CC = ""
.BCC = ""
.Subject = "FindItemOnWorksheet Error"
.Body = strbody
'.Attachments.Add ("C:\file.xlsx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
FindItemOnWorksheet = "Error"
'wb.Close
Exit Function
End Function
Function GetWB(ByVal NAVDate As Date) As Workbook
'Open requested workbook, return to parent procedure
Dim wbPath As String
Dim wbYear As String
Dim wbMonth As String
Dim wbWeek As String
Dim wbFile As String
Dim wbString As String
Dim wb As Workbook
Dim BackADay As Boolean
Dim OriginalNAVDateRequested As Date
OriginalNAVDateRequested = NAVDate
BackADay = True
'Loop through possible file tree structures and dates to find the closest NAV in the past to the date requested.
Do While BackADay = True
'Don't go back to a previous week if cannot find current NAV
If OriginalNAVDateRequested - NAVDate > 4 Then
BackADay = False
End If
wbPath = <Network Path Removed>
wbYear = CStr(Year(NAVDate)) & "\"
wbMonth = MonthName(Month(NAVDate)) & " " & wbYear
wbWeek = DateFormat(NAVDate) & "\"
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
'Pricings with distributions have differing tree structure
If wbFile = "" Then
wbWeek = wbWeek & "POST Distribution " & wbWeek
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
If wbFile = "" Then
NAVDate = NAVDate - 1
Else: BackADay = False
End If
Else: BackADay = False
End If
Loop
wbString = wbPath & wbYear & wbMonth & wbWeek & wbFile
Set wb = Workbooks.Open(wbString, UpdateLinks:=False, ReadOnly:=True)
Set GetWB = wb
End Function
Function DateFormat(ByVal X As Date) As String
'Appends leading zeroes if needed to achieve form "00" for any two digit integer, and converts to string
Dim MM As String
Dim DD As String
Dim YYYY As String
If Month(X) < 10 Then
MM = "0" & CStr(Month(X))
Else
MM = CStr(Month(X))
End If
If Day(X) < 10 Then
DD = "0" & CStr(Day(X))
Else
DD = CStr(Day(X))
End If
YYYY = CStr(Year(X))
DateFormat = MM & "." & DD & "." & YYYY
End Function
您可以在 Worksheet_Change 活动中打开工作簿。
为了演示，如果 Sheet1!A2、Excel 中的更改将尝试打开具有该单元格值的工作簿名称，然后将状态输出到 Sheet1!A4.
放在下面的模块中：
Option Explicit
Function TryOpenWB(ByVal oItem As Variant) As Variant
Dim sOut As String
Dim oWB As Workbook
On Error Resume Next
Set oWB = Workbooks.Open(CStr(oItem))
If oWB Is Nothing Then
sOut = "Cannot open """ & CStr(oItem) & """"
Else
sOut = "Opened """ & CStr(oItem) & """ successfully."
'oWB.Close
End If
TryOpenWB = sOut
End Function
然后在下面的Worksheet Module中（我用Sheet1来演示）：
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range("A2").Address Then
Application.EnableEvents = False
Range("A4").Value = TryOpenWB(Target)
Application.EnableEvents = True
End If
End Sub
所以这个想法是只有当某些单元格地址匹配时才打开工作簿。
UDF "NAV()" 旨在根据第一个参数（始终是日期）在网络驱动器上找到正确的报告，然后遍历所有工作表以找到与第二个相同行的数据参数和与第三个参数相同的列（第二个和第三个可以是文本或数字）。
立即可靠地工作window。总是 returns #VALUE！在工作表上使用时，例如=NAV(D7,D8,D9) 或 =NAV(2/19/2016,"Net Asset Value","221-I").
一般来说，如果试图改变 UDF 中的其他单元格，看起来可能会出现这种行为，但我的函数不会那样做。另外，我相信所有范围引用都指定了哪个工作簿和工作表，所以我认为这也不是问题所在。我不确定下一步要看哪里。
当找不到用户正在查找的内容时，该功能还会尝试通过 Outlook 通过电子邮件向我发送报告。我不知道这是否相关。
同样，令人困惑的是这段代码似乎立即可以正常工作 window，但只给出 #VALUE！在工作表上使用时。
我还可以在下面的代码中查看其他什么地方来确定什么会导致 NAV() 立即正确运行 window，但总是产生 #VALUE！什么时候用在工作表上？
Option Explicit
Function NAV(ByVal NAVDate As Date, ByVal matchRow As Variant, ByVal matchColumn As Variant) As Variant
'Application.ScreenUpdating = False
Application.Volatile True
NAV = FindItemOnWorksheet(NAVDate, matchRow, matchColumn)
'Application.ScreenUpdating = True
End Function
Function FindItemOnWorksheet(ByVal NAVDate As Date, ByVal ItemSpecies As Variant, ByVal ItemGenus As Variant) As Variant
' Finds Item by opening NAV workbook with correct date, activating correct worksheet, and searching for correct row and column
Dim startingRange As Range
Dim ws As Worksheet
Dim wb As Workbook
Dim theDate As Date
Dim theItemSpecies As String
Dim theItemGenus As String
theDate = NAVDate
theItemSpecies = ItemSpecies
theItemGenus = ItemGenus
Set wb = GetWB(NAVDate)
'Loop through ws
Dim WS_Count As Integer
Dim i As Integer
WS_Count = wb.Worksheets.Count
For i = 1 To WS_Count
Set ws = wb.Worksheets(i)
Set startingRange = ws.Range("A1:Z100")
Dim theRow As Range
Dim theColumn As Range
Set theRow = startingRange.Cells.Find(theItemSpecies, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theRow Is Nothing) Then
Set theColumn = startingRange.Cells.Find(theItemGenus, SearchDirection:=xlPrevious, lookat:=xlWhole)
If Not (theColumn Is Nothing) Then
FindItemOnWorksheet = ws.Cells(theRow.Row, theColumn.Column).Value
wb.Close
Exit Function
End If
End If
Next i
'Loop if no hit on either row or column Find()
'following executes only if no match found
MsgBox "No Match Found. Make sure you are entering arguments--" & vbNewLine & _
" The Date of NAV, " & vbNewLine & _
" the entry found in the right row of NAV workbooks (e.g. 'Net Asset Value'), " & vbNewLine & _
" the right column (e.g. 'Fund')." & vbNewLine & _
" This function will only find exact matches." & vbNewLine & vbNewLine & _
"Now emailing developer to ask for a fix."
Dim OutApp As Object
Dim OutMail As Object
Dim strbody As String
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "User attempted" & _
"=FindItemOnWorksheet( " & theDate & ", " & theItemSpecies & ", " & theItemGenus & " )" & vbNewLine & _
"theDate type " & TypeName(theDate) & vbNewLine & _
"theItemSpecies type " & TypeName(theItemSpecies) & vbNewLine & _
"theItemGenus type " & TypeName(theItemGenus)
On Error Resume Next
With OutMail
.To = <Address Removed>
.CC = ""
.BCC = ""
.Subject = "FindItemOnWorksheet Error"
.Body = strbody
'.Attachments.Add ("C:\file.xlsx")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
FindItemOnWorksheet = "Error"
'wb.Close
Exit Function
End Function
Function GetWB(ByVal NAVDate As Date) As Workbook
'Open requested workbook, return to parent procedure
Dim wbPath As String
Dim wbYear As String
Dim wbMonth As String
Dim wbWeek As String
Dim wbFile As String
Dim wbString As String
Dim wb As Workbook
Dim BackADay As Boolean
Dim OriginalNAVDateRequested As Date
OriginalNAVDateRequested = NAVDate
BackADay = True
'Loop through possible file tree structures and dates to find the closest NAV in the past to the date requested.
Do While BackADay = True
'Don't go back to a previous week if cannot find current NAV
If OriginalNAVDateRequested - NAVDate > 4 Then
BackADay = False
End If
wbPath = <Network Path Removed>
wbYear = CStr(Year(NAVDate)) & "\"
wbMonth = MonthName(Month(NAVDate)) & " " & wbYear
wbWeek = DateFormat(NAVDate) & "\"
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
'Pricings with distributions have differing tree structure
If wbFile = "" Then
wbWeek = wbWeek & "POST Distribution " & wbWeek
wbFile = Dir(wbPath & wbYear & wbMonth & wbWeek & "*Valuation Package*.xlsx")
If wbFile = "" Then
NAVDate = NAVDate - 1
Else: BackADay = False
End If
Else: BackADay = False
End If
Loop
wbString = wbPath & wbYear & wbMonth & wbWeek & wbFile
Set wb = Workbooks.Open(wbString, UpdateLinks:=False, ReadOnly:=True)
Set GetWB = wb
End Function
Function DateFormat(ByVal X As Date) As String
'Appends leading zeroes if needed to achieve form "00" for any two digit integer, and converts to string
Dim MM As String
Dim DD As String
Dim YYYY As String
If Month(X) < 10 Then
MM = "0" & CStr(Month(X))
Else
MM = CStr(Month(X))
End If
If Day(X) < 10 Then
DD = "0" & CStr(Day(X))
Else
DD = CStr(Day(X))
End If
YYYY = CStr(Year(X))
DateFormat = MM & "." & DD & "." & YYYY
End Function
您可以在 Worksheet_Change 活动中打开工作簿。
为了演示，如果 Sheet1!A2、Excel 中的更改将尝试打开具有该单元格值的工作簿名称，然后将状态输出到 Sheet1!A4.
放在下面的模块中：
Option Explicit
Function TryOpenWB(ByVal oItem As Variant) As Variant
Dim sOut As String
Dim oWB As Workbook
On Error Resume Next
Set oWB = Workbooks.Open(CStr(oItem))
If oWB Is Nothing Then
sOut = "Cannot open """ & CStr(oItem) & """"
Else
sOut = "Opened """ & CStr(oItem) & """ successfully."
'oWB.Close
End If
TryOpenWB = sOut
End Function
然后在下面的Worksheet Module中（我用Sheet1来演示）：
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range("A2").Address Then
Application.EnableEvents = False
Range("A4").Value = TryOpenWB(Target)
Application.EnableEvents = True
End If
End Sub
所以这个想法是只有当某些单元格地址匹配时才打开工作簿。