为了账号安全,请及时绑定邮箱和手机立即绑定

在Excel中使用UDF更新工作表

/ 猿问

在Excel中使用UDF更新工作表

在Excel中使用UDF更新工作表

这并不是一个问题,而是将此作为评论发布,因为我不记得以前见过这种方法。我对之前的一个答案做出了回应,并尝试了一些我以前从未尝试过的东西:结果很有趣,所以我想把它作为一个独立的问题,连同我自己的答案一起发布。

在so(和许多其他论坛)中,有许多问题是关于“我的用户定义的函数出了什么问题”的,其中的回答是“您不能从UDF更新工作表”-这个限制在这里概述了如下:

Excel中自定义函数的局限性描述

为了克服这一问题,已经描述了几种方法,例如,请参阅这里(https:/sites.google.com/site/e90e50/excel-公式-更改另一个单元格的值但我不认为我的确切方法就是其中之一。

另见:更改UDF中的单元格注释


查看完整描述

3 回答

?
一只斗牛犬

张贴一个回复,这样我就可以把我自己的“问题”标记为有答案了。


我已经看到了其他的解决办法,但这似乎更简单,我很惊讶它能起作用。


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

请张贴更多的答案,如果您有趣的申请,这是您想要分享的。


注:未经测试的任何一种真正的“生产”应用程序。


查看完整回答
反对 回复 2019-06-19
?
翻过高山走不出你

这个MSDN KB是不正确的。

上面写着

由工作表单元格中的公式调用的用户定义函数无法更改MicrosoftExcel的环境。这意味着这种职能不能执行下列任何一项任务:

  1. 插入、删除或

    格式单元格

    在电子表格上。
  2. 更改另一个单元格的值.

  3. 向工作簿移动、重命名、删除或添加工作表。
  4. 更改任何环境选项,如计算模式或屏幕视图。

  5. 向工作簿添加名称.

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

在下面的代码中,可以很容易地看到点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 redEnd 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 eventsSub ChangeEvents(RefCell As Range)
    Application.EnableEvents = FalseEnd Sub



查看完整回答
反对 回复 2019-06-19
?
炎炎设计


我知道这是一个旧线程,我不确定你们中是否有人已经发现了这一点,但是我发现,您不仅可以添加、删除或修改Udf中的形状,还可以添加Querytables..我正在构建一个加载项,它使用这个概念返回给定一系列值的SQL数据,而不是Ctrl+Shift+Enter方法的数组函数,因为我的许多最终用户不擅长理解他们的使用,


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

表值函数,该函数将分隔字符串解析为表变量:


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;


查看完整回答
反对 回复 2019-06-19
  • 3 回答
  • 0 关注
  • 148 浏览
我要回答
慕课专栏
更多

添加回答

回复

举报

0/150
提交
取消
意见反馈 帮助中心 APP下载
官方微信