从Excel中的数组公式(from Name Manager)在VBA中创建数组

Question

我试图从Excel中的动态数组公式在VBA中创建一个数组。理想情况下，Excel公式将保存在名称管理器中，但我可以接受如果公式存储在单元格中。

最终目标是使用该数组根据特定条件(使用For循环)匹配单元格块，以确定要从Excel工作表中删除的行块。它必须是动态的，因为我不知道工作表中有多少行，也不知道在运行时之前需要删除哪些行。

到Excel文件的链接:https://www.dropbox.com/s/rz1qej15afht6bx/BRE5560_RFQ.xlsx?dl=0

我已经试了好几天了，试了很多不同的选择，但我不能让它工作。令人恼火的是，对于另一个返回double数组的公式来说，它工作得很好，但这个string数组却违背了我。

Function CreateRFQEmail(sRFQFileName As String)
Dim arrRows() As Variant
Dim arrRFQs2() As Variant 
objExcel.Workbooks.Open (sRFQFileName)
Set sht = objExcel.ActiveWorkbook.Worksheets(2)
'This creates the array of Doubles without issue:
arrRows = sht.Evaluate(sht.Names.Item("Quote!vbaRows").Value)
'The best result I have with this line is to have an array of Strings in VBA with the 
'correct number of elements, but the first element from Excel is repeated for each 
'element in the array:
arrRFQs2 = sht.Evaluate(sht.Names.Item("Quote!vbaRFQs").Value)
End Function

我也试过使用:

arrRFQs2 = sht.Names.Item("Quote!vbaRFQs").Value   'Error - Can't assign to array
arrRFQs2 = sht.Names("Quote!vbaRFQs").Value        'Error - Can't assign to array
arrRFQs2 = sht.Range("BY5").Value                  'Error - Type mismatch

我试过几个其他的选项，但是我记不住它们。(如果有人建议我已经尝试过的东西，我会保持帖子更新)最常见的错误是类型不匹配，即使我可以确认行的公式一侧(即sht.Range("BY5") value)是字符串或范围

名称管理器中存储的Excel公式如下:

'vbaRFQs:
=TOROW(IF(Quote!vbaRows,INDEX(Quote!$A:$A,Quote!vbaRows),""))
'The first IF is needed to get VBA to return the correct number of elements, 
'without it I just get an array with a single element even though in Excel the 
'formula returns an array correctly
'vbaRows:
=IFERROR(TOROW(SMALL(IF(Quote!$A:$A<>"",ROW(Quote!$A:$A),""),ROW(OFFSET(Quote!$A:$A,0,0,COUNTA(Quote!$A:$A),1)))),"")

我还尝试将它们放在单元格中，而不是没有更改的名称管理器。

我已经尝试使vbaRFQs一个长公式，而不是使用它里面的vbarrows，但这只适用于如果我删除第一个if(因为它将太长评估)，然后我只得到一个元素数组在VBA。

如果我使用vbaRFQs的索引公式，那么VBA将公式视为范围类型(即使公式的结果是字符串)，并给我一个类型不匹配的错误。

Answer 1

使用命名公式填充数组

• 我认为这个配方太复杂了，不能和Evaluate一起使用。
• 这是一个使用第一列的值和rows数组中的信息(行)的解决方案。

Sub CreateRFQEmailTEST()
CreateRFQEmail "C:TestBRE5560_RFQ.xlsx"
End Sub

Sub CreateRFQEmail(ByVal sRFQFilePath As String)

Dim swb As Workbook: Set swb = Workbooks.Open(sRFQFilePath)
Dim sws As Worksheet: Set sws = swb.Sheets("Quote")
Dim sData(): sData = sws.UsedRange.Columns(1).Value

' Get Rows.
Dim ArrRows(): ArrRows = sws.Evaluate("vbaRows")

' Get RQFs.

Dim ArrRFQs(): ReDim ArrRFQs(1 To UBound(ArrRows))

Dim rItem, dc As Long

For Each rItem In ArrRows
dc = dc + 1
ArrRFQs(dc) = sData(rItem, 1)
Next rItem

' Print both.
Debug.Print Join(ArrRows, ",")
Debug.Print Join(ArrRFQs, ",")

End Sub