如何从 VBA 中的两个数组函数获取单个数组输出？

Posted 2023-04-13

【中文标题】如何从 VBA 中的两个数组函数获取单个数组输出？

【英文标题】：How do I get single array output from two array functions in VBA?

【发布时间】：2021-01-29 08:21:45

【问题描述】：

我正在做一个项目，我必须从一系列数据中生成一个输出表。我能够从数据列表中生成唯一值，并且能够计算各个值的计数、平均值和标准偏差。但是，我无法连接这两个功能。谁能告诉我如何从一个函数执行所有内容的解决方案？

我想从数组输出中调用代码中的 Uniques 函数，然后对这些值执行数学函数。

代码

Option Explicit

Public Function uniques(myrange As Range)
    Dim list As New Collection
    Dim Ulist() As String
    Dim value As Variant
    Dim i As Integer
    'Adding each value of myrang into the collection.
    On Error Resume Next
    For Each value In myrange
        'here value and key are the same. The collection does not allow duplicate keys hence only unique values will remain.
        list.Add CStr(value), CStr(value)
    Next
    On Error GoTo 0

    'Defining the length of the array to the number of unique values. Since the array starts from 0, we subtract 1.
    ReDim Ulist(list.Count - 1, 0)

    'Adding unique value to the array.
    For i = 0 To list.Count - 1
        Ulist(i, 0) = list(i + 1)
    Next

    'Printing the array
    uniques = Ulist
End Function

Public Function findtext(tofind As String, myrange As Range) As Integer
    
    ' Removed RA from dim
    Dim i As Integer
    Dim rcount As Integer
    rcount = 0

    For i = 1 To myrange.Rows.Count
        'tofind = uniques(myrange.Cells.value)
        If myrange(i, 1) = tofind Then
            rcount = rcount + 1
        End If
    Next i

    findtext = rcount

End Function

Public Function findavg(tofind As String, myrange As Range)
    Dim avg As Double, rcount As Integer
    Dim SUM As Double, findtext As Double
    Dim i As Integer
    SUM = 0
    rcount = 0
    For i = 1 To myrange.Rows.Count
        If myrange(i, 1) = tofind Then
            SUM = SUM + myrange(i, 2)
            rcount = rcount + 1
            avg = SUM / rcount
        End If
    Next i
    findavg = avg

End Function

Public Function findstd(tofind As String, myrange As Range)
    Dim std As Double, rcount As Integer
    Dim SUM As Double, avg As Double, totalstd As Double
    Dim i As Integer
    
    SUM = 0
    std = 0
    rcount = 0
    
    For i = 1 To myrange.Rows.Count              'i to active selection
        If myrange(i, 1) = tofind Then           'criteria = "A"....etc
            SUM = SUM + myrange(i, 2)            'sum in loop
            rcount = rcount + 1                  'add & count in loop
            avg = SUM / rcount
        End If
    Next i
    For i = 1 To myrange.Rows.Count
        If myrange(i, 1) = tofind Then
            std = std + (myrange(i, 2) - avg) ^ 2
        End If
    Next i
    
    findstd = Sqr(std / (rcount - 1))
End Function

Function arrayutput(tofind As String, myrange As Range) As Variant

    'we take it as zero because we haven't taken option base1
    Dim Output(0, 2) As Variant

    Output(0, 0) = findtext(tofind, myrange)     'first column
    Output(0, 1) = findavg(tofind, myrange)      'second column
    Output(0, 2) = findstd(tofind, myrange)

    arrayutput = Output

End Function

【问题讨论】：

听起来你想要一个 sub 来确定事件的顺序并调用各种函数并使用它们的返回值做一些事情。你真的不想要一个超级函数。

恐怕你问的方式不太友好......并不是所有人都会花时间试图理解你的（很多）代码。因此，请尝试用文字解释您要完成的工作。您证明尝试了一些东西...从您的图片中我可以理解的是：左侧的三列是要处理的范围（看到列和行标题应该很好...）。并且您必须获得正确的情况，这意味着获得唯一值、它们的计数、计数的平均值和标准偏差。这种理解正确吗？

@FaneDuru 感谢您的反馈，我同意我可以更好地解释它。老实说，我有点恐慌。所以我要做的是从评级和优惠券数据中选择唯一值，并尝试在小表中计算它们的数据。是的，我正在尝试获取唯一的评级值（“A”、“AAA”等）以及相应的计数、平均值和标准偏差

@QHarr 这个问题我需要一个函数而不是一个子函数，有没有办法从函数调用一个子函数？

您可以从函数中调用Sub。但它不能返回任何东西。我的意思是它只会运行......

【参考方案1】：

请尝试下一个代码。它使用字典来解决唯一部分、计数和总和，然后处理其数据并填充数组。它的内容立即被丢弃在范围内。代码假设要处理的范围在A:C列，处理结果放在从“G2”开始的范围内：

Sub testExtractDataAtOnce()
'the code needs a reference to 'Microsoft Scripting Runtime'
 Dim sh As Worksheet, lastRow As Long, arr, arrIt, arrFin
 Dim i As Long, dict As New Scripting.Dictionary
 
 Set sh = ActiveSheet                   'use here your necessary sheet
 lastRow = sh.Range("B" & sh.Rows.count).End(xlUp).row
 arr = sh.Range("B2:C" & lastRow).Value 'put the range to be processed in an array
 
 For i = 1 To UBound(arr)               'process the array and fill the dictionary
    If Not dict.Exists(arr(i, 1)) Then
        dict.Add arr(i, 1), 1 & "|" & arr(i, 2) 'create the unique key and corresponding count | value
    Else
        arrIt = Split(dict(arr(i, 1)), "|") 'extract the count and previous value and use it in the next line
        'add the count and the new value to the existing key data:
        dict(arr(i, 1)) = CLng(arrIt(0)) + 1 & "|" & CDbl(arrIt(1)) + arr(i, 2)
    End If
 Next i

 ReDim arrFin(1 To dict.count, 1 To 4) 'redim the final array to accept all the necessary fields
 Dim avg As Double, std As Double
 For i = 0 To dict.count - 1           'iterate between the dictionary data
    arrIt = Split(dict.Items(i), "|")  'extract the count and the value (sum)
    arrFin(i + 1, 1) = dict.Keys(i): arrFin(i + 1, 2) = arrIt(0) 'write the key and count
    avg = arrIt(1) / arrIt(0)          'calculate the average (neccessary for the next steps, too)
    arrFin(i + 1, 3) = avg             'put the average in the array
    'call the adapted function (able to extract the stdDev from the array):
    arrFin(i + 1, 4) = findstd(CStr(dict.Keys(i)), avg, CDbl(arrIt(0)), arr)
 Next i
 'Drop the processed result in the sheet, at once. You can use any range instead of "G2" and any sheet
 sh.Range("G2").Resize(UBound(arrFin), 4).Value = arrFin
End Sub

Public Function findstd(tofind As String, avg As Double, rcount As Long, arr)
    Dim std As Double, i As Long

    For i = 1 To UBound(arr)
        If arr(i, 1) = tofind Then
            std = std + (arr(i, 2) - avg) ^ 2
        End If
    Next i
    findstd = Sqr(std / (rcount - 1))
End Function

请测试一下，发送一些反馈。

如果您不知道如何添加引用，请在运行上面的代码之前运行下一个代码。它会自动添加必要的引用：

Sub addScrRunTimeRef()
  'Add a reference to 'Microsoft Scripting Runtime':
  'In case of error ('Programmatic access to Visual Basic Project not trusted'):
  'Options->Trust Center->Trust Center Settings->Macro Settings->Developer Macro Settings->
  '         check "Trust access to the VBA project object model"
  Application.VBE.ActiveVBProject.References.AddFromFile "C:\Windows\SysWOW64\scrrun.dll"
End Sub

【讨论】：

@Kannav Bhatia：你没有抽出时间来测试上面的代码吗？如果经过测试，它没有满足您的需求吗？

嘿，我会测试它并告诉你！感谢您的帮助:)