Using a UDF in Excel to update the worksheet

Question

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 some

Answer 1

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,

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.

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;

Answer 2

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.

Answer 3

The MSDN KB is incorrect.

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:

1. Insert, delete, or format cells on the spreadsheet.
2. Change another cell's value.
3. Move, rename, delete, or add sheets to a workbook.
4. Change any of the environment options, such as calculation mode or screen views.
5. Add names to a workbook.
6. Set properties or execute most methods.

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

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