通过在一个单元格中输入公式来填充不同单元格的数组公式

Posted 2023-04-19

【中文标题】通过在一个单元格中输入公式来填充不同单元格的数组公式

【英文标题】：Fill array formula for different cells by entering formula in one cell

【发布时间】：2017-01-19 17:49:09

【问题描述】：

我现在正在尝试实现类似query function in Google Sheets 的目标。显然，在这个 GIF 中，已经有人这样做了。我想知道他们如何在 Excel / VBA 中做到这一点。

我的具体问题是：在 VBA 中，如何通过在特定单元格中输入公式来填充其他单元格的公式？ （复制此 GIF 中使用的功能，不使用 VBA + 高级过滤器）

在单元格 A3 中输入公式 按 CTRL + SHIFT + ENTER 接收结果

这是我目前得到的：

标准模块中的代码：

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

这段代码在activesheet的模块中：

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

08.04.2019 更新：找到解决方案

' 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

要测试它，请转到 Excel 工作表，在 A1 中输入以下测试公式：

=fRandArray(10,10)

P.S：如果有人在使用 Excel 365 Insider Program，微软已经发布了这种称为动态数组函数的公式： https://support.office.com/en-ie/article/dynamic-arrays-and-spilled-array-behavior-205c6b06-03ba-4151-89a1-87a7eb36e531

【问题讨论】：

使用高级过滤器。有很多关于如何使用 vba 实现这一点的教程。

感谢您的回复，我问：在VBA中，并通过输入公式。不使用高级过滤器 + VBA

我知道你问了什么，最接近的答案是使用高级过滤器，这就是 Excel 的自然做法。您在 gif 中看到的是一个附加组件，而不是不需要大量编程就可以完成的事情。我建议如果你想要你所看到的，然后为附加组件付费。

我对很多编程都很好，几年前我写了一些类似的东西，但我需要将“触发公式”放到不同的单元格中。是的，它来自一个 excel 插件。

那么请发布您的尝试并具体告诉使用它失败的地方。如您所知，SO 不是我网站的代码。

【参考方案1】：

我同意其他 cmets 的观点 - MS 似乎没有提供本地执行此操作的方法，任何直接执行此操作的方法都可能涉及一些破坏 Excel 的内存操作。

不过……

我建议将你的方法更进一步并推广它

将该类复制并粘贴到文本文件中，然后将其导入 VBA（允许 Attribute VB_PreDeclaredID = True 和 Attribute Item.VB_UserMemId = 0）：

范围编辑

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

使您的 Workbook_SheetChange 方法如下：

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

现在您可以创建修改其他单元格的 UDF。它的工作方式是将您所做的所有修改排队，并且仅在单元格失去焦点后运行它们。该语法允许您将其视为几乎像常规 Range 函数一样。您可以使用地址字符串或实际范围运行它（但如果不是其中之一，您可能需要添加错误）。

这是一个可以从 Excel 单元格公式运行的快速示例 UDF：

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 intColIndex = 0 To rs.Fields.Count - 1
    Range("A1").Offset(0, intColIndex).Value = rs.Fields(intColIndex).Name
Next

与

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

为了复制记录集，我将定义以下函数（它假定记录集光标设置为第一条记录。如果您之前移动它，您可能希望在其中包含rs.MoveFirst）：

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

【讨论】：

嗨，请查看我上面的解决方案 :)