时间戳

首页 > 解决方案 > 如何将多个表传递给 VBA 函数并返回？

arrays - 如何将多个表传递给 VBA 函数并返回？

问题描述

我已经就这个主题提出了几个问题，但这里有一个总结：为了工作，我需要能够通过几个技术文件（excel 和 word）来收集数据并将所有这些数据带到一个漂亮的 excel 表中。

我做了第一次尝试，并决定从头开始（几乎，我复制了我在第一次尝试时已经完成的一些不错的代码功能）

而且，在某些情况下，我需要获得与欧元和美元价格相关的几个工具参考。

因此，我有一个名为GetToolPrices()To 的漂亮函数，我给出了工具引用列表（通过一个表），我想取回 2 个名为ToolPriceEuro()and的表ToolPriceDollard()。好消息是“工具 1”在每个表的第一个位置都有它的信息，所以，稍后，我只需要获取所有表，选择第一个信息，我知道它是用于工具 1 的。

那么，如何通过一个函数发回两张表呢？例如，在收集工具引用的函数“GetTools”中，我通过 this 将其发送回，这GetTools = RCTable()是RCTable()在将工具引用发送回主程序之前填充工具引用的临时表。这很好用！但我不知道如何以这种方式发回两张表......我有点发现这些功能，所有这些，在不同的网页上阅读了很多东西，但这没有帮助:(

主要代码

For Each Fol In Worksheets("Data").Range("TPIFold") 'For each Folder in all the adresses indexed in the cells called "TPIFold"
    For Each Fil In fso.GetFolder(Fol).Files  'For each file found in each one of these folders
        ReDim RCodeTab(1)  'reset the tables
        ReDim ToolTab(1)
        FileExt = fso.GetExtensionName(Fil)  'Get the extension name
        FileNm = fso.GetFileName(Fil) 'Get the file name
        If FileExt = "docx" Then
            If ReadFiles = vbYes Then
                FileTab(1) = GetCode(FileNm) 'Get the Code of the file present in the folders and copy it to the tables
                FileTab(2) = GetName(FileNm) 'Get the name of the file and delete the underscores
            End If
            If FileTab(1) <> "" And FileTab(2) <> "" Then 'If the file got a code and a name that have been recognized

'Opens the good Word file
                oApp.Visible = True
                FilAdress = Fil
                Set oDoc = oApp.Documents.Open(FilAdress, ReadOnly:=True)                   'Open the word document
'Gather everything needed from this word file and store that in Tables
                RCodeTab() = GetRCode(FileNm)   'That's not important for now ;)
                ToolTab() = GetTools(FileNm)    'Here we got the tools references

                ToolPrices() = GetToolPrices(ToolPriceEuro(), ToolPriceDollard()) 'This, obviously don't work...

            End If
        End If
    Next
Next

这是我想发回 2 张桌子的功能......

Public Function GetToolPrices(ToolTab() As String) As Variant

Dim ToolPriceEuro() As String
Dim ToolPriceDollard() As String

Dim Collect As Collection
Set Collect = New Collection

PriceListFold = Worksheets("Data").Range("F2").Value & "\" & Worksheets("Data").Range("F3").Value   'The folder where there is the price list
PriceListFile = Worksheets("Data").Range("F3").Value 'The file where the price list is
PriceListSheet = Worksheets("Data").Range("F4").Value  'gets the name of the sheet on which all the data are written. Theorically, it should not change
Bidule = 1  'Initialisation

Workbooks.Open Filename:=PriceListFold, ReadOnly:=True 'open the file with the list of prices and references
EndRange = Range("A:A").SpecialCells(xlCellTypeLastCell).Address 'Gets the last used cell of the column A
EndRangePos = InStr(2, EndRange, "$")
EndRange = Right(EndRange, Len(EndRange) - EndRangePos)                                                 'And keeps just the line number
EndRange = CInt(EndRange)


 Do While Bidule <= UBound(ToolTab())
    PartNumber = ToolTab(Bidule)                                               'Gets the Part number
         If PartNumber <> "" Then
            PassThrough = 1
            SearchResult = False
            Do While PassThrough <= EndRange
                SheetCode = Worksheets(PriceListSheet).Range("A" & PassThrough).Text
                If SheetCode = PartNumber Then
                    Worksheets(PriceListSheet).Range("A" & PassThrough).Activate
                    ResultCell = Worksheets(PriceListSheet).Range("A" & PassThrough).Address
                    Tempo = ActiveCell.Offset(0, 2)
                    ReDim Preserve ToolPriceEuro(1 To Bidule)
                    ToolPriceEuro(Bidule) = Tempo
                    Tempo = ActiveCell.Offset(0, 5)
                    ReDim Preserve ToolPriceDollard(1 To Bidule)
                    ToolPriceDollard(Bidule) = Tempo
                    PassThrough = EndRange
                    SearchResult = True
                End If
                PassThrough = PassThrough + 1
            Loop
            If SearchResult = False Then
                ToolPriceEuro(Bidule) = "Not Found"
                ToolPriceDollard(Bidule) = "Not Found"
            End If
        End If
        Bidule = Bidule + 1
Loop

Collect.Add ToolPriceEuro()
Collect.Add ToolPriceDollard()

GetToolPrices = ToolPriceEuro() & ToolPriceDollard() 'That don't work, it's sad, it would be so easy...


End Function

这段代码中肯定有一些不合逻辑、无用或其他的东西，但这并不重要，正如开头所说，我正在恢复第一次尝试的部分内容，之后我会清理它，当我有至少有点工作的东西。

现在，最大的问题是“我如何发回两个名为ToolPriceEuro()&的表ToolPriceDollard()”

提前谢谢！

额外的小问题：我伤害了“Stackoverflow 标签输入框”，我无法创建“表格”标签......我使用并认为被称为表格的这些东西的名称是什么？数组？数组不是相似但略有不同吗？;-)

标签： arraysexcelvba

解决方案

它们确实是数组（法语中的“tableau”，可以合理地翻译为“table”）！;-)

不过，数组在 VBA 中有点特殊。您可以Variant从过程中返回一个数组作为 a Function，但是如果您需要返回其中两个，那么您可以利用 [implicit default]ByRef修饰符，因此调用者可以简单地查询它传递给您的函数的相同数组指针：

Public Sub Fill(ByRef foo() As Variant)
    ReDim foo(1 To 10)
    Dim i As Long
    For i = LBound(foo) To UBound(foo)
        foo(i) = i
    Next
End Sub

此过程的调用者需要提供一个数组：

Dim items() As Variant
Fill items
Debug.Print UBound(items)

或者，如果这两个数组密切相关，您可以将它们包装在一个对象中，并返回该对象的一个​​实例。在最简单、最天真的形式中，这将是一个Class1可能如下所示的模块：

Option Explicit
Public PricesEUR As Variant
Public PricesUSD As Variant

然后你的函数可以做：

Dim result As Class1
Set result = New Class1
result.PricesEUR = ToolPriceEuro
result.PricesUSD = ToolPriceDollard
Set GetToolPrices = Class1

需要将返回类型更改为Class1（或您为类指定的任何有意义的名称）：

Public Function GetToolPrices(ByRef ToolTab() As String) As Class1

...但是，如果所有“工具”的价格都相同，那么您最终会得到“并行”数组，这是一种设计味道。一个更好的解决方案是定义一些ItemPrice类 - 这里又是一个简单/天真的实现：

Public ItemCode As String
Public CurrencyCode As String
Public Amount As Currency

现在您可以返回一个数组（或者更好的是 a Collection，可以通过键入它ItemCode & CurrencyCode来轻松检索任何Amount）这些ItemPrice项目，每个项目都知道它们使用的货币以及它们的项目/工具代码。

GetToolPrices = ToolPriceEuro() & ToolPriceDollard() 'That don't work, it's sad, it would be so easy...

它不起作用，因为&使用这种方式是字符串连接运算符：当你给它数组操作数时，VBA 不知道你的意思，因为数组不能被强制转换为字符串，所以你可能会得到一个类型不匹配错误。

推荐阅读