blocks|key|2744977|text|发布一个回复，这样我就可以将我自己的“问题”标记为有答案。|type|unstyled|depth|inlineStyleRanges|entityRanges|data|2744978|我见过其他的变通方法，但是这个看起来更简单，我很惊讶它还能工作。|2744979|Sub+ChangeIt(c1+As+Range,+c2+As+Range)
++++c1.Value+=+c2.Value
++++c1.Interior.Color+=+IIf(c1.Value+>+10,+vbRed,+vbYellow)
End+Sub


'########++run+as+a+UDF,+this+actually+changes+the+sheet+##############
'+changing+value+in+c2+updates+c1...
Function+SetIt(src,+dest)

++++dest.Parent.Evaluate+"Changeit("+&+dest.Address(False,+False)+&+","+_
++++++++++++++++++++++++&+src.Address(False,+False)+&+")"

++++SetIt+=+"Changed+sheet!"+'or+whatever+return+value+is+useful...

End+Function|code-block|syntax|javascript|2744980|如果您对此有感兴趣的应用程序，请发布其他答案，以便与他人分享。|2744981|注意：在任何类型的真正的“生产”应用程序中都未经测试。|offset|length|style|BOLD|2744982|entityMap^0|0|0|0|0|0|3|0^^$0|@$1|2|3|4|5|6|7|S|8|@]|9|@]|A|$]]|$1|B|3|C|5|6|7|T|8|@]|9|@]|A|$]]|$1|D|3|E|5|F|7|U|8|@]|9|@]|A|$G|H]]|$1|I|3|J|5|6|7|V|8|@]|9|@]|A|$]]|$1|K|3|L|5|6|7|W|8|@$M|X|N|Y|O|P]]|9|@]|A|$]]|$1|Q|3|-4|5|6|7|Z|8|@]|9|@]|A|$]]]|R|$]]

Posting a response so I can mark my own "question" as having an answer.

I've seen other workarounds, but this seems simpler and I'm surprised it works at all.

<pre><code>Sub ChangeIt(c1 As Range, c2 As Range)
 c1.Value = c2.Value
 c1.Interior.Color = IIf(c1.Value &gt; 10, vbRed, vbYellow)
End Sub


'######## run as a UDF, this actually changes the sheet ##############
' changing value in c2 updates c1...
Function SetIt(src, dest)

 dest.Parent.Evaluate "Changeit(" &amp; dest.Address(False, False) &amp; "," _
 &amp; src.Address(False, False) &amp; ")"

 SetIt = "Changed sheet!" 'or whatever return value is useful...

End Function
</code></pre>

Please post additional answers if you have interesting applications for this which you'd like to share.

Note: Untested in any kind of real "production" application.

blocks|key|156528|text|MSDN+KB不正确。|type|unstyled|depth|inlineStyleRanges|entityRanges|offset|length|data|156529|上面写着|156530|156531|由工作表单元格中的公式调用的用户定义函数不能更改Microsoft+Excel的环境。这意味着这样的函数不能执行以下任何操作：|blockquote|156532|156533|156534|将另一个单元格的名称重命名、删除或添加到工作表上重命名、删除或添加工作表任何环境选项，如计算模式或将views.|156535|Add名称添加到workbook.|unordered-list-item|style|BOLD|156536|
|156537|Set属性或执行大多数方法。|156538|在另一个单元格的属性上插入、删除或格式单元格。|ordered-list-item|156539|156540|156541|在下面的代码中，你可以看到1，2,4和5点可以很容易地实现。|156542|Function+SetIt(RefCell)
++++RefCell.Parent.Evaluate+"SetColor("+&+RefCell.Address(False,+False)+&+")"
++++RefCell.Parent.Evaluate+"SetValue("+&+RefCell.Address(False,+False)+&+")"
++++RefCell.Parent.Evaluate+"AddName("+&+RefCell.Address(False,+False)+&+")"

++++MsgBox+Application.EnableEvents
++++RefCell.Parent.Evaluate+"ChangeEvents("+&+RefCell.Address(False,+False)+&+")"
++++MsgBox+Application.EnableEvents

++++SetIt+=+""
End+Function

'~~>+Format+cells+on+the+spreadsheet.
Sub+SetColor(RefCell+As+Range)
++++RefCell.Interior.ColorIndex+=+3+'<~~+Change+color+to+red
End+Sub

'~~>+Change+another+cell's+value.
Sub+SetValue(RefCell+As+Range)
+++RefCell.Offset(,+1).Value+=+"Sid"
End+Sub

'~~>+Add+names+to+a+workbook.
Sub+AddName(RefCell+As+Range)
+++RefCell.Name+=+"Sid"
End+Sub

'~~>+Change+events
Sub+ChangeEvents(RefCell+As+Range)
++++Application.EnableEvents+=+False
End+Sub|code-block|syntax|javascript|156543|​|156544|📷|atomic|156545|156546|entityMap|0|LINK|mutability|MUTABLE|url|https://support.microsoft.com/en-us/kb/170787|1|IMAGE|IMMUTABLE|imageUrl|https://ask.qcloudimg.com/http-save/yehe-900000/ef20f3ffd97430259f39add53513b57d.png|imageAlt^0|0|7|0|0|0|0|0|0|0|0|0|G|0|0|0|H|5|0|0|0|0|0|0|0|1|1|0|0^^$0|@$1|2|3|4|5|6|7|1S|8|@]|9|@$A|1T|B|1U|1|1V]]|C|$]]|$1|D|3|E|5|6|7|1W|8|@]|9|@]|C|$]]|$1|F|3|-4|5|6|7|1X|8|@]|9|@]|C|$]]|$1|G|3|H|5|I|7|1Y|8|@]|9|@]|C|$]]|$1|J|3|-4|5|6|7|1Z|8|@]|9|@]|C|$]]|$1|K|3|-4|5|6|7|20|8|@]|9|@]|C|$]]|$1|L|3|M|5|6|7|21|8|@]|9|@]|C|$]]|$1|N|3|O|5|P|7|22|8|@$A|23|B|24|Q|R]]|9|@]|C|$]]|$1|S|3|T|5|6|7|25|8|@]|9|@]|C|$]]|$1|U|3|V|5|P|7|26|8|@]|9|@]|C|$]]|$1|W|3|X|5|Y|7|27|8|@$A|28|B|29|Q|R]]|9|@]|C|$]]|$1|Z|3|-4|5|6|7|2A|8|@]|9|@]|C|$]]|$1|10|3|-4|5|6|7|2B|8|@]|9|@]|C|$]]|$1|11|3|12|5|6|7|2C|8|@]|9|@]|C|$]]|$1|13|3|14|5|15|7|2D|8|@]|9|@]|C|$16|17]]|$1|18|3|19|5|6|7|2E|8|@]|9|@]|C|$]]|$1|1A|3|1B|5|1C|7|2F|8|@]|9|@$A|2G|B|2H|1|2I]]|C|$]]|$1|1D|3|19|5|6|7|2J|8|@]|9|@]|C|$]]|$1|1E|3|-4|5|6|7|2K|8|@]|9|@]|C|$]]]|1F|$1G|$5|1H|1I|1J|C|$1K|1L]]|1M|$5|1N|1I|1O|C|$1P|1Q|1R|-4]]]]

The <a href="https://support.microsoft.com/en-us/kb/170787" rel="noreferrer">MSDN KB</a> is incorrect.

It says

<blockquote>
 A user-defined function called by a formula in a worksheet cell cannot change the environment of Microsoft Excel. This means that such a function cannot do any of the following:
</blockquote>

<ol>
<li>Insert, delete, or format cells on the spreadsheet.</li>
<li>Change another cell's value.</li>
<li>Move, rename, delete, or add sheets to a workbook.</li>
<li>Change any of the environment options, such as calculation mode or screen views.</li>
<li>Add names to a workbook.</li>
<li>Set properties or execute most methods.</li>
</ol>

In the below code you can see points 1, 2,4 and 5 can be easily achieved.

<pre><code>Function SetIt(RefCell)
 RefCell.Parent.Evaluate "SetColor(" &amp; RefCell.Address(False, False) &amp; ")"
 RefCell.Parent.Evaluate "SetValue(" &amp; RefCell.Address(False, False) &amp; ")"
 RefCell.Parent.Evaluate "AddName(" &amp; RefCell.Address(False, False) &amp; ")"

 MsgBox Application.EnableEvents
 RefCell.Parent.Evaluate "ChangeEvents(" &amp; RefCell.Address(False, False) &amp; ")"
 MsgBox Application.EnableEvents

 SetIt = ""
End Function

'~~&gt; Format cells on the spreadsheet.
Sub SetColor(RefCell As Range)
 RefCell.Interior.ColorIndex = 3 '&lt;~~ Change color to red
End Sub

'~~&gt; Change another cell's value.
Sub SetValue(RefCell As Range)
 RefCell.Offset(, 1).Value = "Sid"
End Sub

'~~&gt; Add names to a workbook.
Sub AddName(RefCell As Range)
 RefCell.Name = "Sid"
End Sub

'~~&gt; Change events
Sub ChangeEvents(RefCell As Range)
 Application.EnableEvents = False
End Sub
</code></pre>

<a href="https://i.stack.imgur.com/xx3js.png" rel="noreferrer"><img src="https://i.stack.imgur.com/xx3js.png" alt="![enter image description here"></a>

blocks|key|2957650|text|我知道这是一个旧的线程，我不确定你们中是否有人已经发现了这一点，但我发现您不仅可以从自定义函数中添加、删除或修改形状，还可以添加Querytables。我正在构建一个插件，它使用这个概念来返回给定一系列值的SQL数据，而不是数组函数的Ctrl%2BShift%2BEnter方法，因为我的许多最终用户都不够精通excel，无法理解它们的用法。|type|unstyled|depth|inlineStyleRanges|offset|length|style|CODE|entityRanges|data|2957651|注意：下面的代码100%25处于测试阶段，有很大的改进空间，但它确实说明了概念。这也是一段不错的代码，但我不想留下任何疑问。|BOLD|2957652|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+%2B+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)+%2B+1+skip+first+value+of+array
++++++++++++For+i+=+LBound(arryInPut,+1)+%2B+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+=+"%7C"

++++++++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+%2B+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+_
++++++++++++++++++++++++++++++++++++%2B+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+=+"[%5E\d]%2B"
++++++++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%2B"
++++++++StripNumbers+=+.Replace(strIn,+"")
++++End+With
End+Function|code-block|syntax|javascript|2957653|将分隔字符串解析为表变量的表值函数：|2957654|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['+%2B+REPLACE(@STR_IN,+'%7C',+']]></r><r><![CDATA[')+%2B+']]></r>'+
++++++++++++INSERT+INTO+@TableOut(ReturnedCol)
++++++++++++SELECT+RTRIM(LTRIM(T.c.value('.',+'NVARCHAR(4000)')))
++++++++++++FROM+@xml.nodes('//r')+T(c)
++++RETURN
++++END
GO|2957655|使用的存储进程：|2957656|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;|2957657|entityMap^0|1S|B|39|G|0|0|3|0|0|D|5|0|0|3|5|0|0^^$0|@$1|2|3|4|5|6|7|X|8|@$9|Y|A|Z|B|C]|$9|10|A|11|B|C]]|D|@]|E|$]]|$1|F|3|G|5|6|7|12|8|@$9|13|A|14|B|H]]|D|@]|E|$]]|$1|I|3|J|5|K|7|15|8|@]|D|@]|E|$L|M]]|$1|N|3|O|5|6|7|16|8|@$9|17|A|18|B|H]]|D|@]|E|$]]|$1|P|3|Q|5|K|7|19|8|@]|D|@]|E|$L|M]]|$1|R|3|S|5|6|7|1A|8|@$9|1B|A|1C|B|H]]|D|@]|E|$]]|$1|T|3|U|5|K|7|1D|8|@]|D|@]|E|$L|M]]|$1|V|3|-4|5|6|7|1E|8|@]|D|@]|E|$]]]|W|$]]

I know this is an old thread, and I am not sure if any of you have already discovered this, but I found that not only can you add, delete, or modify shapes from a UDF, you can also add <code>Querytables</code>. I am building an addin at work that uses this concept to return SQL data given a range of values, in place of the <code>Ctrl+Shift+Enter</code> method of array functions, because many of the my end-users are not excel savvy enough to understand their use,

NOTE: The code below is 100% in the testing phase and there is a lot of room for improvement, but it does illustrate the concept. Also it is a decent bit of code, but I didn't want to leave anything to question. 

<pre><code>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 &gt; 1 Then
 MsgBox "The input Range cannot be more than" _
 &amp; " a single column.", vbCritical + vbOKOnly, "Error:" _
 &amp; " 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 &gt; 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 &gt; 0 Then Conn.Close
 If Not RcrdsetReturned Is Nothing Then: If RcrdsetReturned.State &gt; 0 Then RcrdsetReturned.Close
 If Not RcrdsetOut Is Nothing Then: If RcrdsetOut.State &gt; 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=************;" &amp; _ 
 "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 &gt; 0 Then ConnIn.Close
 If Not RcrdsetIn Is Nothing Then: If RcrdsetIn.State &gt; 0 Then RcrdsetIn.Close
 Set ConnIn = Nothing
 Set RcrdsetIn = Nothing
 Set Cmnd = Nothing

 'Sometimes the error numer &lt;&gt; &gt; 0 hence the else statement
 If Err.Number &gt; 0 Then
 MsgBox "Error Number: " &amp; Err.Number &amp; "- " &amp; Err.Description &amp; _
 " , occured while attempting to exectute the query.", _
 vbCritical, "Error: " &amp; Err.Number
 Else
 MsgBox "An error occured while attempting to execute the query. " &amp; _
 "Try typing the formula again. If the issue persits" &amp; _
 "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 &gt; 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 &amp; ":" &amp; strRangeBegin &amp; CStr(lngRangeEnd)

 If Application.CountA(ActiveSheet.Range(strRangeOut)) &gt; 1 Then

 strCheckUserInput = MsgBox("There is data in range " &amp; strRangeOut &amp; " are you sure" &amp; _
 "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
</code></pre>

Table Valued Function that Parses delimited String into Table variable: 

<pre><code>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'&lt;r&gt;&lt;![CDATA[' + REPLACE(@STR_IN, '|', ']]&gt;&lt;/r&gt;&lt;r&gt;&lt;![CDATA[') + ']]&gt;&lt;/r&gt;' 
 INSERT INTO @TableOut(ReturnedCol)
 SELECT RTRIM(LTRIM(T.c.value('.', 'NVARCHAR(4000)')))
 FROM @xml.nodes('//r') T(c)
 RETURN
 END
GO
</code></pre>

Stored Procedured Used: 

<pre><code>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;
</code></pre>

Not really a question, but posting this for comments because I don't recall seeing this approach before. I was responding to a comment on a previous answer, and tried something I'd not attempted before: the result was interesting so I though I'd post it as a stand-alone question, along with my own answer.

There have been many questions here on SO (and many other forums) along the lines of "what's wrong with my user-defined function" where the answer has been "you can't update a worksheet from a UDF" - this restriction outlined here:

<a href="http://support.microsoft.com/kb/170787">Description of limitations of custom functions in Excel</a>

There are a few methods which have been described to overcome this e.g. see here (<a href="https://sites.google.com/site/e90e50/excel-formula-to-change-the-value-of-another-cell">https://sites.google.com/site/e90e50/excel-formula-to-change-the-value-of-another-cell</a>) but I don't think my exact approach is among them.

See also: <a href="http://spreadsheetpage.com/index.php/oddity/a_user_define_function_cant_change_the_worksheet_oh_yeah/">changing cell comments from a UDF</a>

Using a UDF in Excel to update the worksheet

这不是一个真正的问题，而是发表评论，因为我不记得以前见过这种方法。我正在回复对之前答案的评论，并尝试了一些我以前没有尝试过的东西:结果很有趣，所以我想我应该把它作为一个独立的问题发布，以及我自己的答案。在SO (和许多其他论坛)上有很多关于“我的用户定义函数出了什么问题”的问题，答案是“你不能从UDF更新工作表”--这...

问在Excel中使用UDF更新工作表
EN

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问在Excel中使用UDF更新工作表EN

社区

活动

资源

关于

腾讯云开发者

热门产品

热门推荐

更多推荐

问在Excel中使用UDF更新工作表
EN