I know this is an old thread, and I'm not sure if any of you have already discovered this, but I have found that you can not only add, remove or modify shapes from UDF, but also add Querytables . I am creating an add-in at work that uses this concept to return SQL data with a given range of values, instead of the Ctrl+Shift+Enter array method, because many of my end users are not well versed in Excel to understand their use.
NOTE. The code below at the testing stage is 100%, and there are many opportunities for improvement, but it really illustrates the concept. Also, this is a decent piece of code, but I did not want to leave anything in doubt.
Option Explicit Public Function GetPNAverages(ByRef RangeSource As Range) As Variant Dim arrySheet As Variant Dim lngRowCount As Long, i As Long Dim strSQL As String Dim rngOut As Range Dim objQryTbl As QueryTable Dim dictSQLData As Dictionary Dim RcrdsetReturned As ADODB.Recordset, RcrdsetOut As ADODB.Recordset Dim Conn As ADODB.Connection Application.ScreenUpdating = False If RangeSource.Columns.Count > 1 Then MsgBox "The input Range cannot be more than" _ & " a single column.", vbCritical + vbOKOnly, "Error:" _ & " Invalid Range Dimensions" Exit Function End If lngRowCount = RangeSource.Rows.Count If RngHasData(Application.Caller.Address, lngRowCount) Then Exit Function arrySheet = RangeSource strSQL = ArryToDelimStr(arrySheet, lngRowCount) If Not GetRecordSet(strSQL, "JDE.GetPNAveragesTEST", _ "@STR_PN", RcrdsetReturned, Conn) Then GoTo StopExecution Call BuildDictionary(dictSQLData, RcrdsetReturned, lngRowCount) Call LeftOuterJoin(dictSQLData, arrySheet, RcrdsetOut, lngRowCount) GetPNAverages = dictSQLData.Item(RangeSource.Cells(1, 1).Value2) 'first value If lngRowCount > 1 Then 'Place query table below first cell Set rngOut = Range(Application.Caller.Address).Offset(1, 0) 'add query table to the range Set objQryTbl = ActiveWorkbook.ActiveSheet.QueryTables.Add(RcrdsetOut, rngOut) With objQryTbl .FieldNames = False .RefreshStyle = xlOverwriteCells .BackgroundQuery = False .AdjustColumnWidth = False .PreserveColumnInfo = True .PreserveFormatting = True .Refresh End With 'deletes any query table from _ ots destination range to avoid _ having external connections rngOut.QueryTable.Delete End If StopExecution: Application.ScreenUpdating = True Application.EnableEvents = True If Not Conn Is Nothing Then: If Conn.State > 0 Then Conn.Close If Not RcrdsetReturned Is Nothing Then: If RcrdsetReturned.State > 0 Then RcrdsetReturned.Close If Not RcrdsetOut Is Nothing Then: If RcrdsetOut.State > 0 Then RcrdsetOut.Close Set Conn = Nothing Set RcrdsetReturned = Nothing Set RcrdsetOut = Nothing End Function Private Function GetRecordSet(ByRef strDelimIn As String, ByVal strStoredProcName As String, _ ByVal strStrdProcParam As String, ByRef RcrdsetIn As ADODB.Recordset, _ ByRef ConnIn As ADODB.Connection) As Boolean Dim Cmnd As ADODB.Command Const strConn = "Provider=VersionOfSQL;User ID=************;Password=************;" & _ "Data Source=ServerName;Initial Catalog=DataBaseName" On Error GoTo ErrQueryingData Set ConnIn = New ADODB.Connection ConnIn.CursorLocation = adUseClient 'this is key for query table to work ConnIn.Open strConn Set Cmnd = New ADODB.Command With Cmnd .CommandType = adCmdStoredProc .CommandText = strStoredProcName .CommandTimeout = 300 .ActiveConnection = ConnIn End With Set RcrdsetIn = New ADODB.Recordset Cmnd.Parameters(strStrdProcParam).Value = strDelimIn RcrdsetIn.CursorType = adOpenKeyset RcrdsetIn.LockType = adLockReadOnly Set RcrdsetIn = Cmnd.Execute If RcrdsetIn.EOF Or RcrdsetIn.BOF Then GoTo ErrQueryingData Else GetRecordSet = True Set Cmnd = Nothing Exit Function ErrQueryingData: If Not ConnIn Is Nothing Then: If ConnIn.State > 0 Then ConnIn.Close If Not RcrdsetIn Is Nothing Then: If RcrdsetIn.State > 0 Then RcrdsetIn.Close Set ConnIn = Nothing Set RcrdsetIn = Nothing Set Cmnd = Nothing 'Sometimes the error numer <> > 0 hence the else statement If Err.Number > 0 Then MsgBox "Error Number: " & Err.Number & "- " & Err.Description & _ " , occured while attempting to exectute the query.", _ vbCritical, "Error: " & Err.Number Else MsgBox "An error occured while attempting to execute the query. " & _ "Try typing the formula again. If the issue persits" & _ "please contact (Developer Name).", vbCritical, _ "Error: Could Not Query Data" End If End Function Private Sub BuildDictionary(ByRef dictToReturn As Dictionary, ByRef RcrdsetIn As ADODB.Recordset, _ ByVal lngRowCountIn As Long) 'building a second recordset because I only want one field from the 'recordset returned by 'GetRecordSet', and I cannot subset it 'using any properties of the query table that I know of Set dictToReturn = New Dictionary dictToReturn.CompareMode = BinaryCompare With RcrdsetIn If lngRowCountIn > 1 Then .MoveFirst Do While Not RcrdsetIn.EOF 'Populate dictionary with key=LookUpValues; Item=ReturnValues If Not dictToReturn.Exists(.Fields(0).Value) Then dictToReturn(.Fields(0).Value) = .Fields(1).Value End If .MoveNext Loop Else 'only 1 value dictToReturn(.Fields(0).Value) = .Fields(1).Value End If End With End Sub Private Sub LeftOuterJoin(ByRef dictIn As Dictionary, ByRef arryInPut As Variant, _ ByRef RcrdsetToReturn As ADODB.Recordset, ByVal lngRowCountIn As Long) Dim i As Long Dim varKey As Variant If lngRowCountIn = 1 Then Exit Sub Set RcrdsetToReturn = New ADODB.Recordset With RcrdsetToReturn .Fields.Append "Field1", adVariant, 10, adFldMayBeNull .CursorType = adOpenKeyset .LockType = adLockBatchOptimistic .CursorLocation = adUseClient .Open If Not .BOF Then .MoveNext 'LBound(arryInPut, 1) + 1 skip first value of array For i = LBound(arryInPut, 1) + 1 To UBound(arryInPut, 1) .AddNew varKey = arryInPut(i, 1) If dictIn.Exists(varKey) Then .Fields(0).Value = dictIn.Item(varKey) Else .Fields(0).Value = "DNE" End If varKey = Empty .Update .MoveNext Next i End With End Sub Private Function ArryToDelimStr(ByRef arryFromRngIn As Variant, ByVal lngRowCountIn As Long) As String Dim arryOutPut() As Variant Dim i As Long Const strDelim As String = "|" If lngRowCountIn = 1 Then ArryToDelimStr = arryFromRngIn Exit Function End If 'Note: 1-based to match the worksheet array ReDim arryOutPut(1 To lngRowCountIn) For i = LBound(arryFromRngIn, 1) To lngRowCountIn arryOutPut(i) = arryFromRngIn(i, 1) Next i ArryToDelimStr = Join(arryOutPut, strDelim) End Function Public Function RngHasData(ByVal strCallAddress As String, ByVal lngRowCountIn As Long) As Boolean Dim strRangeBegin As String, strRangeOut As String, _ strCheckUserInput As String Dim lngRangeBegin As Long, lngRangeEnd As Long strRangeBegin = StripNumbers(strCallAddress) lngRangeBegin = StripText(strCallAddress) lngRangeEnd = lngRangeBegin + lngRowCountIn strRangeOut = strCallAddress & ":" & strRangeBegin & CStr(lngRangeEnd) If Application.CountA(ActiveSheet.Range(strRangeOut)) > 1 Then strCheckUserInput = MsgBox("There is data in range " & strRangeOut & " are you sure" & _ "that you want to overwrite it?", vbInformation _ + vbYesNo, "Alert: Data In This Range") If strCheckUserInput = vbNo Then RngHasData = True End If End Function Private Function StripText(ByRef strIn As String) As Long With CreateObject("vbscript.regexp") .Global = True .Pattern = "[^\d]+" StripText = CLng(.Replace(strIn, vbNullString)) End With End Function Private Function StripNumbers(strIn As String) As String With CreateObject("VBScript.RegExp") .Global = True .Pattern = "\d+" StripNumbers = .Replace(strIn, "") End With End Function
A table function that parses a delimited string in a table variable:
SET ANSI_NULLS ON GO SET QUOTED_IDENTIFIER ON GO CREATE FUNCTION dbo.fn_Get_REGDelimStringToTable (@STR_IN NVARCHAR(MAX)) RETURNS @TableOut TABLE(ReturnedCol NVARCHAR(4000)) AS BEGIN DECLARE @XML xml = N'<r><![CDATA[' + REPLACE(@STR_IN, '|', ']]></r><r><![CDATA[') + ']]></r>' INSERT INTO @TableOut(ReturnedCol) SELECT RTRIM(LTRIM(Tcvalue('.', 'NVARCHAR(4000)'))) FROM @xml.nodes('//r') T(c) RETURN END GO
Used stored procedures:
CREATE PROCEDURE [JDE].[GetPNAveragesTEST] ( @STR_PN NVARCHAR(MAX) ) AS BEGIN SELECT TT.ReturnedCol ,IsNull(Cast(pnm.AVERAGE_COST As nvarchar(35)), 'DNE') as AVERAGE_COST FROM dbo.fn_Get_MAXDelimStringToTable(@STR_PN) TT Left Join PN_Interchangeable pni ON TT.ReturnedCol=pni.PN_Interchangeable Left Join PN_MASTER pnm On pni.MPN=pnm.MPN END;