VBA excel查找集合的统计模式

Question

因此，我尝试在 Excel 中分析一些数据，但在查找最常见的数字时遇到了一些麻烦。我有一个未知数量的地点，可以有未知数量的捐赠。例如

• 布兰特福德 $50.00
• 布兰特福德 $25.00
• 布兰特福德 $50.00
• 温莎 $200.00
• 魁北克 $25.00
• 魁北克 $100.00
• 魁北克 $50.00
• 魁北克 $50.00
• 魁北克 $25.00
• 魁北克 $50.00
• 魁北克 $50.00
• 魁北克 $25.00
• 魁北克 $100.00
• 魁北克 $40.00
• 温莎 $140.00
• 温莎 $20.00
• 温莎 $20.00

所以我需要使用 VBA 来查找每个位置的计数、总和、平均值和模式（必须通过 VBA 完成，不能只编写有关如何使用高级过滤器/数据透视表执行此操作的说明 :() .

所以现在使用 VBA 我有一个字典对象，它将位置名称存储为键，并将每个捐赠存储在一个集合中。使用我有计数的集合的计数，可以很容易地循环遍历集合以获得总和，使用我的平均值；但是，我不确定获得该模式的最有效方法。

我知道如果我的数据位于使用 Application.mode 的数组中，我可以找到它，但这似乎不适用于集合 :(。将集合转换为数组虽然可以找到模式，但实际上并没有让我觉得是最有效的解决方案。我能找到的唯一其他选择是对集合进行排序，然后遍历它们以找到模式。

所以想知道是否有人知道找到集合统计模式的好方法？

Dim locdata As Object
Set locdata = CreateObject("scripting.dictionary")  

For counter = 2 To max
    mykey = Cells(counter, loccol).value
    If Not (locdata.exists(mykey)) Then
        locdata.Add (mykey), New Collection
    End If
    locdata(mykey).Add (Cells(counter, donamountcol).value)
Next counter
For Each k In locdata.keys
    locname = k
    Cells(counter, 1) = k
    Cells(counter, 2) = locdata(k).Count
    donationtotal = 0
    For Each donvalue In locdata(k)
        donationtotal = donationtotal + donvalue
    Next donvalue
    Cells(counter, 3) = donationtotal
    Cells(counter, 4) = donationtotal / CDbl(locdata(k).Count)
    'Cells(counter, 5) = Application.mode(locdata(k)) doesn't work :(
    counter = counter + 1
Next k

edit：理想情况下，输出应该是（以魁北克为例） 魁北克：计数：10 总和：515 平均：51.5 众数：50

Answer 1

以下是如何将范围内的值动态地放入数组中。我会在 VBA 中使用 CountIF 来按名称查找最常见的对象。因为你不知道 location names 或 donations。 那么数组就是要走的路。

Dim ar as Variant
Dim endRow as Long

'get last row in the range
endRow = Sheets(1).Cells(Sheets(1).Rows.Count, "A").End(xlUp).Row    
'ar = WorksheetFunction.Transpose(Shets(1).Range("A1:A12")
 'using endrow
 ar = WorksheetFunction.Transpose(Shets(1).Range("A1").resize(endRow).value)

更新：下面的subroutine 使用一次迭代（for 循环）来查找Mode..

Sub FrequencyByLocDonations()
Dim ar As Variant, dc As Object
Dim rngInput As Range, mxRng As Range
Dim endRow As Long, i As Integer
Dim counts As Double, maxLoc As Double
Dim maxLocation As String
   Set dc = CreateObject("Scripting.Dictionary")

   '-- When you know the range
   '   ar = WorksheetFunction.Transpose(Shets(1).Range("A1:A12").Value

    'get last row in the range when you don't know but the starting cell
    endRow = Sheets(3).Cells(Sheets(3).Rows.Count, "C").End(xlUp).Row
    Set rngInput = Sheets(3).Range("C2").Resize(endRow - 1, 1)

    '--you may also use that set rngInput as well
    '   WorksheetFunction.Transpose(rngInput).Value

    '-- using endrow-1 to not to take an extra blank row at the end
    ar = WorksheetFunction.Transpose(Sheets(3).Range("C2").Resize(endRow - 1, 2).Value)

    For i = LBound(ar, 2) To UBound(ar, 2)
        If Not (dc.exists(ar(1, i))) Then
            counts = Application.WorksheetFunction.CountIf(rngInput, ar(1, i))
            If counts >= maxLoc Then
                maxLocation = ar(1, i)
                maxLoc = counts
            End If
            dc.Add ar(1, i), counts
        End If
    Next i

    '-- output to the Sheet
    Sheets(3).Range("C2").Offset(0, 2).Resize(UBound(dc.keys) + 1, 1) = _ 
              Application.Transpose(dc.keys)
    Sheets(3).Range("C2").Offset(0, 3).Resize(UBound(dc.items) + 1, 1) = _
              Application.Transpose(dc.items)
    Sheets(3).Range("C2").Offset(0, 4) = "Most Frequent Location :" _ 
              & maxLocation & "; " & maxLoc

    Set dc = Nothing
End Sub

输出：

Answer 2

我过去也遇到过类似的情况。在我看来，excel 中缺少一个非常强大的 VBA 函数 - 相当于 MySQL 中的“where”语句。
所以我自己写了一个非常简单的......这缺少很多功能，但它可以让你做你想要的，同时最大限度地减少你编写的代码量。
基本概念：可以从函数调用中返回一个数组，Excel 内置函数可以对这样的数组进行操作，就像对函数进行操作一样。因此，如果您有一个返回“我想要模式的所有数字”的函数，那么=MODE(myfunction()) 会给您想要的答案。
我选择调用我的函数subset(criteria, range1, range2)。
它以最简单的形式返回 range2 中与 range1 中满足条件的元素相对应的元素。 这没有经过广泛的测试，但我希望你能明白。
顺便说一句，您可以在多个单元格中将其作为数组公式（shift-ctrl-enter）输入；在这种情况下，您会在第一个单元格中获得第一个返回的元素，等等。有时，当您有一个需要返回多个值（例如范围）的函数时，这是一个有用的技巧 - 但对于这种情况，您只需要结果喂给另一个函数。

Option Explicit
' Function subset(criteria, range1, range2)
' Return an array with the elements in range2 that correspond to
' elements in range1 that match "criteria"
' where "criteria" can be a string, or a value with a < = > sign in front of it

' example: =subset("bravo", A1:A10, B1:B10)
' returns all cells from B that corresponds to cells in A with "bravo"
' =subset("<10", A1:A10, B1:B10) returns all cells in B corresponding to
' cells in A with a value < 10
' This is analogous to the "where" function in SQL, but much more primitive

Function subset(criteria As String, range1 As Range, range2 As Range)
Dim c
Dim result
Dim ii, jj As Integer
On Error GoTo etrap

If range1.Cells.Count <> range2.Cells.Count Then Exit Function
ReDim result(1 To range1.Cells.Count)
ii = 1
jj = 1
For Each c In range1.Cells
If compare(c.Value, criteria) = 0 Then
  result(ii) = range2.Cells(jj).Value
  ii = ii + 1
End If
jj = jj + 1
Next c

If ii > 1 Then
ReDim Preserve result(1 To ii - 1)
subset = result
Else
subset = Nothing
End If

Exit Function
etrap:
MsgBox "Error " & Err.Description
End Function

Private Function compare(a, b)
' type of a decides what kind of comparison we do
If TypeName(a) <> TypeName("hello") Then
' use numerical comparison
compare = Not (Evaluate(a & b))
Else
' use string comparison
compare = StrComp(a, b, vbTextCompare)
End If
End Function

Answer 3

我实际上只是决定制作一本字典。所以我有位置和每个位置，而不是每个捐赠金额的字典。很容易以这种方式比较计数以找到模式。