Question

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

我的具体问题是：在VBA中，如何填充其他单元格＆＃39;通过在特定单元格中输入公式来计算公式？（复制此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

此代码位于活动表的模块中：

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，Microsoft已发布了这种名为Dynamic Array Function的公式： https://support.office.com/en-ie/article/dynamic-arrays-and-spilled-array-behavior-205c6b06-03ba-4151-89a1-87a7eb36e531

Answer 1

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

...然而

我建议您将您的方法更进一步推广

将此类复制并粘贴到文本文件中，然后将其导入VBA（允许cat file.html和Attribute VB_PreDeclaredID = True）：

<强> RangeEdit

Attribute Item.VB_UserMemId = 0

将 Workbook_SheetChange 方法设为以下内容：

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

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

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

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

针对您的具体情况，我会替换

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

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

1 个答案: