Fill array formula for different cells by entering formula in one cell

Question

I am now trying to achieve something like the query function in Google Sheets. Obviously in this GIF, someone has already done that. I wonder how they could do that in Excel / VBA.

My specific question is: in VBA, how to fill other cells' formulas by entering a formula in a specific cell? (replicate the function used in this GIF and not using VBA + advanced filter)

1. Enter a formula in cell A3
2. Press CTRL + SHIFT + ENTER
3. Receive results

This is what I got so far:

The code in a standard module:

Sub run_sql_sub(sql)
On Error Resume Next
Set cn = CreateObject("ADODB.Connection")
Set rs = CreateObject("ADODB.Recordset")

With cn
    .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data     Source=" & _
    This Workbook.FullName _
& ";Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1"";"
    .Open
End With
rs.Open sql, cn

Application.ScreenUpdating = False
ActiveSheet.Range("A1:XFD1048576").ClearContents

For intColIndex = 0 To rs.Fields.Count - 1
    Range("A1").Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next

Range("A2").CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close: cn.Close: Set rs = Nothing: Set cn = Nothing
End Sub

And this code is in activesheet's module:

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim KeyCells As Range

    Set KeyCells = ActiveSheet.Range("A1")

    If Not Application.Intersect(KeyCells, Range(Target.Address)) _
       Is Nothing Then

        If InStr(KeyCells.Value2, "mi_sql") > 0 Then
            sql = Right(KeyCells.Value2, Len(KeyCells.Value2) - Len("mi_sql "))
            run_sql_sub sql
        End If
    End If
End Sub

Update 08.04.2019: found a solution

' Code in standard Module
Public collectCal As Collection
Private ccal As CallerCal

Sub subResizeKQ(caller As CallerInfo)
    On Error Resume Next
    Application.EnableEvents = False
    If caller.Id <> "" Then
        Application.Range(caller.Id).ClearContents
        Application.Range(caller.Id).Resize(caller.rows, caller.cols).FormulaArray = caller.FomulaText
    End If
    Application.EnableEvents = True
End Sub


Function ResizeKQ(value As Variant) As Variant
    If ccal Is Nothing Then Set ccal = New CallerCal
    If collectCal Is Nothing Then Set collectCal = New Collection

    Dim caller As New CallerInfo
    Dim rows As Long, cols As Long
    Dim arr As Variant
    arr = value
    rows = UBound(arr, 1) - LBound(arr, 1) + 1
    cols = UBound(arr, 2) - LBound(arr, 2) + 1

    Dim rgcaller As Range
    Set rgcaller = Application.caller
    caller.Id = rgcaller.Address(True, True, xlA1, True, True)
    caller.rows = rgcaller.rows.Count
    caller.cols = rgcaller.Columns.Count
    caller.FomulaText = rgcaller.Resize(1, 1).Formula

    If caller.rows <> rows Or caller.cols <> cols Then
        caller.rows = rows
        caller.cols = cols
        collectCal.Add caller, caller.Id
    End If
    ResizeKQ = arr
End Function

Function fRandArray(numRow As Long, numCol As Long) As Variant
    Application.Volatile True
    ReDim arr(1 To numRow, 1 To numCol)
    For i = 1 To numRow
        For j = 1 To numCol
            arr(i, j) = Rnd
        Next
    Next
    fRandArray = ResizeKQ(arr)
End Function

'--------------------------------------------------------------------------
' code in Class Module name CallerCal

Private WithEvents AppEx As Application

Private Sub AppEx_SheetCalculate(ByVal Sh As Object)
    Dim caller As CallerInfo
    If collectCal Is Nothing Then Exit Sub
    For Each caller In collectCal
        subResizeKQ caller
        collectCal.Remove caller.Id
        Set caller = Nothing
    Next
    Set collectCal = Nothing
End Sub

Private Sub Class_Initialize()
    Set AppEx = Application
End Sub

Private Sub Class_Terminate()
     Set AppEx = Nothing
End Sub

'--------------------------------------------------------------------------
' code in Class Module name CallerInfo

Public rows As Long

Public cols As Long

Public Id As String

Public FomulaText As String

To test it, go to Excel Sheet, enter the following test formula in A1:

=fRandArray(10,10)

P.S: If anyone is using Excel 365 Insider Program, Microsoft has published this kind of formula called Dynamic Array Function: https://support.office.com/en-ie/article/dynamic-arrays-and-spilled-array-behavior-205c6b06-03ba-4151-89a1-87a7eb36e531

Answer 1

I agree with the other comments - MS doesn't seem to provide a way to do this natively, and any way of doing it directly would probably involve some Excel-breaking memory manipulation.

However...

I suggest taking your method one step further and generalizing it

Copy and paste this class into a text file, then import it into VBA (which allows Attribute VB_PreDeclaredID = True and Attribute Item.VB_UserMemId = 0):

RangeEdit

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "RangeEdit"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private colRanges As Collection
Private colValues As Collection

Private Sub Class_Initialize()
    Set colRanges = New Collection
    Set colValues = New Collection
End Sub

Public Property Let Item(rng_or_address As Variant, value As Variant)
Attribute Item.VB_UserMemId = 0
    colRanges.Add rng_or_address
    colValues.Add value
End Property

Public Sub flush(sh As Worksheet)
    Application.EnableEvents = False
    While colRanges.Count > 0

        If TypeName(colRanges(1)) = "Range" Then
            colRanges(1).value = colValues(1)
        ElseIf TypeName(colRanges(1)) = "String" Then
            sh.Range(colRanges(1)).value = colValues(1)
        End If
        colRanges.Remove 1
        colValues.Remove 1

    Wend
    Application.EnableEvents = True
End Sub

Make your Workbook_SheetChange method the following:

Private Sub Workbook_SheetChange(ByVal sh As Object, ByVal Target As Range)
    RangeEdit.flush sh
End Sub

Now you can create a UDF that modifies other cells. The way it works is it queues up all the modifications you make and only runs them after the cell loses focus. The syntax allows you to treat it almost like the regular Range function. You can run it either with an address string or with an actual range (though you might want to add an error if it's not either one of those).

Here is a quick example UDF that can be run from an Excel cell formula:

Public Function MyUDF()
    RangeEdit("A1") = 4
    RangeEdit("B1") = 6
    RangeEdit("C4") = "Hello everyone!"

    Dim r As Range
    Set r = Range("B12")

    RangeEdit(r) = "This is a test of using a range variable"

End Function

---

For your specific case, I would replace

For intColIndex = 0 To rs.Fields.Count - 1
    Range("A1").Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next

with

For intColIndex = 0 To rs.Fields.Count - 1
    RangeEdit(Range("A1").Offset(0, intColIndex)) = rs.Fields(intColIndex).Name
Next

And to copy the recordset I would define the following function (it assumes that the recordset cursor is set to the first record. if you Move it previously you might want to have rs.MoveFirst in there):

Public Sub FormulaSafeRecordsetCopy(rs As ADODB.Recordset, rng As Range)
    Dim intColIndex As Long
    Dim intRowIndex As Long
    While Not rs.EOF
        For intColIndex = 0 To rs.Fields.Count - 1
            RangeEdit(rng.Offset(intRowIndex, intColIndex)) = rs.Fields(intColIndex).value
        Next
        rs.MoveNext
        intRowIndex = intRowIndex + 1
    Wend
End Sub