excel - How do I get single array output from two array functions in VBA?

Question

I am working on a project in which I have to generate a table of output from a range of data. I am able to generate Unique values from the list of data and I am able to calculate Count, Mean and Standard Deviation for the individual values. But, I am not able to connect these two functions. Can anyone tell a solution to how I can execute everything from one function?

I want to call the Uniques function in the code from the array output and then execute a mathematical function on these values.

Code

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

question from:https://stackoverflow.com/questions/65950984/how-do-i-get-single-array-output-from-two-array-functions-in-vba

Answer 1

Please, try the next code. It uses a dictionary to solve the unique part, the count and sum, then process its data and populate an array. Its content is dropped at once in the range. The code assumes that the range to be processed is in columns A:C and the processing result is placed in a range starting from "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

Please test it, send some feedback.

If you do not know how to add a reference, please run the next code before running the above one. It will automatically add the necessary reference:

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:WindowsSysWOW64scrrun.dll"
End Sub