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

我正在尝试实现类似Google表格中的查询function 。 很显然，在这个GIF中，有人已经这样做了。 我不知道他们怎么能在Excel / VBA中做到这一点。

我的具体问题是：在VBA中，如何通过在特定单元格中input公式来填充其他单元格的公式？ （复制在这个GIF中使用的function，而不是使用VBA +高级filter）

1. 在单元格A3中input一个公式
2. 按下CTRL + SHIFT + ENTER
3. 接收结果

这是我到目前为止：

标准模块中的代码：

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 

Answer 1

我同意其他意见 – MS似乎没有提供一种方式来做到这一点本身，任何直接做的方式可能会涉及一些破坏Excel的内存操作。

然而…

我build议把你的方法进一步推广一下

将这个类复制并粘贴到一个文本文件中，然后将其导入到VBA中（允许Attribute VB_PreDeclaredID = True和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 

使您的Workbook_SheetChange方法如下所示：

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

现在你可以创build一个修改其他单元格的UDF。 它的工作方式是排队所有你所做的修改，只有在单元失去焦点后才能运行。 语法可以让你把它看作一般的Range函数。 您可以使用地址string或实际范围运行它（尽pipe如果不是其中之一，您可能想要添加一个错误）。

下面是一个可以从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 

---

对于你的具体情况 ，我会replace

 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 

复制logging集我会定义下面的函数（它假设logging集游标被设置为第一个logging，如果你以前移动它，你可能想在那里有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