vba 在 Excel 中使用 UDF 更新工作表
声明:本页面是StackOverFlow热门问题的中英对照翻译,遵循CC BY-SA 4.0协议,如果您需要使用它,必须同样遵循CC BY-SA许可,注明原文地址和作者信息,同时你必须将它归于原作者(不是我):StackOverFlow
原文地址: http://stackoverflow.com/questions/23433096/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Using a UDF in Excel to update the worksheet
提问by Tim Williams
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:
在 SO(以及许多其他论坛)上有很多问题,如“我的用户定义函数有什么问题”,答案是“您无法从 UDF 更新工作表”-此处概述了此限制:
Description of limitations of custom functions in Excel
There are a few methods which have been described to overcome this e.g. see here (https://sites.google.com/site/e90e50/excel-formula-to-change-the-value-of-another-cell) but I don't think my exact approach is among them.
已经描述了一些方法来克服这个问题,例如见这里(https://sites.google.com/site/e90e50/excel-formula-to-change-the-value-of-another-cell),但我不要认为我的确切方法是其中之一。
See also: changing cell comments from a UDF
另请参阅:从 UDF 更改单元格注释
采纳答案by Tim Williams
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.
我见过其他解决方法,但这似乎更简单,我很惊讶它竟然有效。
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
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.
注意:未经任何类型的真正“生产”应用程序测试。
回答by Siddharth Rout
The MSDN KBis incorrect.
该MSDN KB不正确。
It says
它说
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:
由工作表单元格中的公式调用的用户定义函数无法更改 Microsoft Excel 的环境。这意味着这样的函数不能执行以下任何操作:
- Insert, delete, or format cellson the spreadsheet.
- Change another cell's value.
- Move, rename, delete, or add sheets to a workbook.
- Change any of the environment options, such as calculation mode or screen views.
- Add names to a workbook.
- Set properties or execute most methods.
- 在电子表格中插入、删除或格式化单元格。
- 更改另一个单元格的值。
- 将工作表移动、重命名、删除或添加到工作簿。
- 更改任何环境选项,例如计算模式或屏幕视图。
- 将名称添加到工作簿。
- 设置属性或执行大多数方法。
In the below code you can see points 1, 2,4 and 5 can be easily achieved.
在下面的代码中,您可以看到第 1、2、4 和 5 点可以轻松实现。
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
回答by rickmanalexander
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 Querytables
. I am building an addin at work that uses this concept to return SQL data given a range of values, in place of the Ctrl+Shift+Enter
method of array functions, because many of the my end-users are not excel savvy enough to understand their use,
我知道这是一个旧线程,我不确定你们中是否有人已经发现了这一点,但我发现您不仅可以从 UDF 添加、删除或修改形状,还可以添加Querytables
. 我正在构建一个工作中的插件,它使用这个概念来返回给定值范围的 SQL 数据,而不是Ctrl+Shift+Enter
数组函数的方法,因为我的许多最终用户都不够精通,无法理解它们的使用,
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.
注意:下面的代码 100% 处于测试阶段,还有很大的改进空间,但它确实说明了这个概念。它也是一段不错的代码,但我不想留下任何问题。
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
Table Valued Function that Parses delimited String into 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(T.c.value('.', 'NVARCHAR(4000)')))
FROM @xml.nodes('//r') T(c)
RETURN
END
GO
Stored Procedured Used:
使用的存储过程:
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;