在Excel中使用自定义项更新工作表

这不是一个真正的问题，但我将此贴出来征求意见，因为我不记得以前见过这种方法。我在回复之前一个答案的评论时，尝试了一些我以前从未尝试过的东西：结果很有趣，所以我想我会把它作为一个独立的问题，连同我自己的答案一起发布

在SO（和许多其他论坛）上有很多问题，比如“我的用户定义函数有什么问题”，答案是“你不能从UDF更新工作表”-这里概述了以下限制：

有一些方法已经被描述来克服这一点，例如，请参见此处（），但我认为我的确切方法不在其中

---

另请参见：

发布回复，以便我可以将自己的“问题”标记为有答案

我见过其他的解决办法，但这似乎更简单，我很惊讶它居然能奏效

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

如果你对此有感兴趣的应用程序，并希望与大家分享，请发布其他答案

注意：未在任何类型的实际“生产”应用程序中测试

错误

上面说

由工作表单元格中的公式调用的用户定义函数无法更改Microsoft Excel的环境。这意味着该函数不能执行以下任何操作：

在电子表格上插入、删除或设置单元格格式

更改另一个单元格的值

将工作表移动、重命名、删除或添加到工作簿中

更改任何环境选项，如计算模式或屏幕视图。

向工作簿添加名称

设置属性或执行大多数方法

在下面的代码中，您可以看到第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

函数设置（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=“”
端函数
“~~>格式化电子表格上的单元格。
子集合颜色（参照单元格作为范围）
RefCell.Interior.ColorIndex=3'更改事件
子变更事件（参照单元格作为范围）
Application.EnableEvents=False
端接头

---

我知道这是一个旧线程，我不确定你们是否已经发现了这一点，但我发现，不仅可以从UDF中添加、删除或修改形状，还可以添加

查询表

。我正在构建一个插件，它使用这个概念在给定一系列值的情况下返回SQL数据，而不是数组函数的

Ctrl+Shift+Enter

方法，因为我的许多最终用户对excel不够了解，无法理解它们的用法

注意：下面的代码在测试阶段是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

---

非常有趣……当我尝试从红色变为黄色时，Excel崩溃了！！有人知道为什么会这样吗？我的意思是，说真的，这是魔法。我在Win7HB，Excel2003上测试了它，数值改变正常，但颜色格式不起作用。。另外还有一个解决方法-请参阅答案的第2部分Excel 2010 Win7上的32位64位-已成功！。。一次，然后在重新计算时崩溃。我可以预见的一个警告是，可能会创建一个无限计算循环，使用此方法修改或创建单元格中的值或公式。这可能会重新启动一个计算周期，等等。系统可能无法将其识别（并停止）为循环引用；因此，我们注意到了这些事故。类似于运行在自身之上的事件宏（如工作表_更改）。这个故事的寓意是：如果你试图通过设计来超越“行为”，接受随之而来的任何限制。@Jeeped-同意：这绝对是一种使用风险自负的类型。只是为了辩论-当UDF正在评估/调用Sub时，是否可以说KB是正确的，这实际上是在做改变…？为了便于讨论，那么：P知识库应该清楚地说，

但是，上面/下面的内容可以通过使用Evalute/调用Sub

来实现，而不是发出一个笼统的声明，

这样的函数不能做以下任何事情……

@MacroManNice return；）显然，微软的员工对此没有准备。我还建议为这种情况添加一个新的标签

vba voodoo

things@MacroMan：

显然微软的员工对此没有准备。

我可以理解并接受这一点。我对这些人真正不满的是，他们没有认真对待微软Office的反馈。我不知道在过去的几年里，我在MSDN KBs上留下了多少反馈，但是没有一个反馈被执行！好像他们根本不在乎！他们可能没有——就微软而言，办公室是他们的“摇钱树”，而且（在我看来）在市场上没有任何真正的竞争对手，尤其是在企业方面，所以他们可能可以在这方面表现得有点漠不关心。我想他们会把精力集中在创造一个更新版本的东西上，试图跟上市场的步伐，而不是把现有的东西做得更好。。。

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

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;