UDF returns 数组对于调用范围而言太大或太小
UDF returns array that is too large or too small for the calling range
下面的函数returns一个数组到一个工作表。
我标记了一个区域，键入我的函数，然后按 Ctrl+Shift+Enter 来让单元格填充来自记录集中的数据。
但是如果我的 CSE 函数的选定区域大于返回的记录集，我会收到 #N/A。如果它更小，则不会显示警告。
是否有一种简单的方法可以将 #N/A 替换为 "" 值，并且如果数组函数的范围小于返回的数组 - 以显示警告？
这是我当前的工作函数，returns 来自记录集的数组：
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, varOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim varOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
varOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
varOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional alternative - write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = varOut
' End With
SQL = varOut
Erase varOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
如果你的输出数组小于调用范围，你可以用""填充输出数组中未使用的部分。
如果调用范围太小，你可以显示一个消息框，或者return一个Excel错误值，或者...取决于你想要什么。
如何做这些事情的例子。
Function test()
'Get interesting content
Dim contentOut As Variant
contentOut = [{1,2;3,4}] ' or a database connection, or whatever
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
MsgBox "your range is too small."
' or return #VALUE! error
test = CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 1 To UBound(contentOut, 1)
For iCol = 1 To UBound(contentOut, 2)
varOut(iRow, iCol) = contentOut(iRow, iCol)
Next
Next
test = varOut
End Function
非常感谢Jean的回答，把完整的代码贴出来感谢帮助过我的人！我只对数组进行了一个小的移动，以便显示 header 和最后一列。
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, contentOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim contentOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
contentOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
contentOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional solution: Write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = contentOut
' End With
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
'MsgBox "your range is too small."
' or return #VALUE! error
SQL = "Too small range" 'CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 0 To UBound(contentOut, 1)
For iCol = 0 To UBound(contentOut, 2)
varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol)
Next
Next
SQL = varOut
'Cleanup
Erase contentOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
下面的函数returns一个数组到一个工作表。 我标记了一个区域，键入我的函数，然后按 Ctrl+Shift+Enter 来让单元格填充来自记录集中的数据。
但是如果我的 CSE 函数的选定区域大于返回的记录集，我会收到 #N/A。如果它更小，则不会显示警告。
是否有一种简单的方法可以将 #N/A 替换为 "" 值，并且如果数组函数的范围小于返回的数组 - 以显示警告？
这是我当前的工作函数，returns 来自记录集的数组：
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, varOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim varOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
varOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
varOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional alternative - write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = varOut
' End With
SQL = varOut
Erase varOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function
如果你的输出数组小于调用范围，你可以用""填充输出数组中未使用的部分。
如果调用范围太小，你可以显示一个消息框，或者return一个Excel错误值，或者...取决于你想要什么。
如何做这些事情的例子。
Function test()
'Get interesting content
Dim contentOut As Variant
contentOut = [{1,2;3,4}] ' or a database connection, or whatever
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
MsgBox "your range is too small."
' or return #VALUE! error
test = CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 1 To UBound(contentOut, 1)
For iCol = 1 To UBound(contentOut, 2)
varOut(iRow, iCol) = contentOut(iRow, iCol)
Next
Next
test = varOut
End Function
非常感谢Jean的回答，把完整的代码贴出来感谢帮助过我的人！我只对数组进行了一个小的移动，以便显示 header 和最后一列。
Function SQL(dataRange As Range, CritA As String, CritB As Double) As Variant
Application.Volatile
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim currAddress As String
Dim varHdr, varDat, contentOut As Variant
Dim nc, nr, i, j As Long
SQL = Null
currAddress = ActiveSheet.Name & "$" & dataRange.Address(False, False)
strFile = ThisWorkbook.FullName
strCon = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFile _
& ";Extended Properties=""Excel 12.0;HDR=Yes;IMEX=0"";"
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")
rs.CursorLocation = adUseClient ' required to return the number of rows correctly
cn.Open strCon
strSQL = "SELECT * FROM [" & currAddress & "]" & _
"WHERE [A] = '" & CritA & "' AND [B] >= " & CritB & " " & _
"ORDER BY 10 DESC"
rs.Open strSQL, cn
' Process Column Headings
nc = rs.Fields.Count
ReDim varHdr(nc - 1, 0)
For i = 0 To rs.Fields.Count - 1
varHdr(i, 0) = rs.Fields(i).Name
Next
' Get Rows from the Recordset
nr = rs.RecordCount
varDat = rs.GetRows
' Combing Header and Data and Transpose
ReDim contentOut(0 To nr, 0 To nc - 1)
For i = 0 To nc - 1
contentOut(0, i) = varHdr(i, 0)
Next
For i = 1 To nr
For j = 0 To nc - 1
contentOut(i, j) = varDat(j, i - 1)
Next
Next
' Optional solution: Write Output Array to Sheet2
' With Sheet2
' .Cells.Clear
' .Range("A1").Resize(nr, nc) = contentOut
' End With
'Figure out size of calling range which will receive the output array
Dim nRow As Long: nRow = Application.Caller.Rows.Count
Dim nCol As Long: nCol = Application.Caller.Columns.Count
'Error if calling range too small
If nRow < UBound(contentOut, 1) Or nCol < UBound(contentOut, 2) Then
'Popup message
'MsgBox "your range is too small."
' or return #VALUE! error
SQL = "Too small range" 'CVErr(xlValue)
' or both or whatever else you want there to happen
Exit Function
End If
'Initialise output array to match size of calling range
Dim varOut As Variant
ReDim varOut(1 To nRow, 1 To nCol)
'And fill it with some background value
Dim iRow As Long
Dim iCol As Long
For iRow = 1 To nRow
For iCol = 1 To nCol
varOut(iRow, iCol) = "" ' or "funny bear", or whatever
Next
Next
'Put content in output array and return
For iRow = 0 To UBound(contentOut, 1)
For iCol = 0 To UBound(contentOut, 2)
varOut(iRow + 1, iCol + 1) = contentOut(iRow, iCol)
Next
Next
SQL = varOut
'Cleanup
Erase contentOut
Erase varHdr
Erase varDat
rs.Close
Set rs = Nothing
Set cn = Nothing
End Function