VBA：计算重复出现的顺序答案

【问题标题】：VBA: Count The Order Of Occurrence Of DuplicatesVBA：计算重复出现的顺序
【发布时间】：2019-06-02 10:38:38
【问题描述】：

我有一个包含采购订单列的数据集。许多采购订单是重复的，我有一个我要检查的条件列表，其中之一是重复采购订单发生时的计数。我很难确切地发现如何修改我的代码来做到这一点。基本上我所需要的只是像this post 中的公式一样计算出现次数的东西

到目前为止，我的代码可以计算每个键的重复项总数，如下所示：

Option Explicit
Sub DuplicateOccrencesCount()

    Dim Source_Array
    Dim dict As Object
    Dim i As Long
    Dim colIndex As Integer

    colIndex = 26

    Set dict = CreateObject("Scripting.dictionary")

     Source_Array = Sheet2.Range("A2").CurrentRegion.Value2


    For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
        If dict.Exists(Source_Array(i, colIndex)) Then
            dict.Item(Source_Array(i, colIndex)) = dict.Item(Source_Array(i, colIndex)) + 1
        Else
            dict.Add Source_Array(i, colIndex), 1
        End If
    Next i

    Sheet9.Range("A2").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.keys)
    Sheet9.Range("B2").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.items)

End Sub

但是，我需要每个重复键的出现次数按照字典中出现的顺序，因为它是为了匹配post mentioned above 中的COUNTIF 的功能而构建的。我想用一些东西来查找循环内Source_array的当前行索引处的值是否重复，然后增加一个计数器像这样：

 Option Explicit
 Sub FindDupsInArray()
     Dim Source_Array
     Dim dict As Object
     Dim i As Long
     Dim colIndex As Integer
     Dim counter As Long

       counter = 0
       colIndex = 26

        Set dict = CreateObject("Scripting.dictionary")

        Source_Array = Sheet2.Range("A2").CurrentRegion.Value2

        'On Error Resume Next
        For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
            If dict.Exists(Source_Array(i, colIndex)) Then
                counter = counter + 1
                Source_Array(i, 30) = counter
            End If
        Next i

        Sheet9.Range("A1").Resize(UBound(Source_Array, 1), _
            UBound(Source_Array, 2)) = Source_Array

    End Sub

但是，当条件为真并且数组打印到工作表时，Source_Array(i,30) 对于所有行都是空白的。

任何想法、想法或答案将不胜感激。

更新1：经过反复试验，我想出了以下我计划制作的功能

Sub RunningCounts2()
  Dim dict As Object
  Dim i As Long
  Dim Source_Array

  Set dict = CreateObject("Scripting.Dictionary")

  Source_Array = Sheet2.Range("A2").CurrentRegion.Value2

  For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
     dict(Source_Array(i, 26)) = dict(Source_Array(i, 26)) + 1
     Source_Array(i, 30) = dict(Source_Array(i, 30))
  Next
  Sheet9.Range("B1").Resize(UBound(Source_Array, 1), UBound(Source_Array, 2)).Value = Source_Array  ' <-- writes results on next column. change as needed
End Sub

更新 2：昨晚经过几个小时的反复试验，我想出了以下修订：

Sub GetRunningCounts()
  Dim dict As Object
  Dim i As Long
  Dim Source_Array, OutPut_Array

  Set dict = CreateObject("Scripting.Dictionary")

  Source_Array = Sheet2.Range("A2").CurrentRegion.Value2

  ReDim OutPut_Array(LBound(Source_Array, 1) To UBound(Source_Array, 1), 1 To 1)

  For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
     dict(Source_Array(i, 26)) = dict(Source_Array(i, 26)) + 1
     OutPut_Array(i, 1) = dict(Source_Array(i, 26))
  Next i

  Sheet9.Range("B1").Resize(UBound(OutPut_Array, 1)).Value = OutPut_Array

End Sub

我随后将其转换为 UDF，如下所示：

Function RunningCntOfOccsInArr(Source_Array As Variant, RowIndex As Long, ColIndex As Integer) As Long

Dim dict As Object               ' edit: corrected var spelling

    If IsArray(Source_Array) = False Then
        Exit Function

    ElseIf IsArrayAllocated(Source_Array) = False Then
        Exit Function

    ElseIf (RowIndex < LBound(Source_Array, 1)) Or (RowIndex > UBound(Source_Array, 1)) Then
        Exit Function

    ElseIf (ColIndex < LBound(Source_Array, 2)) Or (ColIndex > UBound(Source_Array, 2)) Then
        Exit Function

    End If

Set dict = CreateObject("Scripting.Dictionary")

    ReDim OutPut_Array(LBound(Source_Array, 1) To UBound(Source_Array, 1), 1 To 1)

    For RowIndex = LBound(Source_Array, 1) To UBound(Source_Array, 1)
        dict(Source_Array(RowIndex, ColIndex)) = dict(Source_Array(RowIndex, ColIndex)) + 1
        OutPut_Array(i, 1)(RowIndex, 1) = dict(Source_Array(RowIndex, ColIndex))
    Next RowIndex

    RunningCntOfOccsInArr = OutPut_Array

End Function

【问题讨论】：

如果只需要COUNTIF，有WorksheetFunction.CountIfdocs.microsoft.com/en-us/office/vba/api/…
对，但是WorksheetFunction.CountIf 不接受我需要的数组。我需要一些模仿countif(A$2:A2, A2) 功能的东西，但第一个参数是数组，第二个参数是数组的行索引。基本上，与countif(A$2:A2, A2) 类似的语法，但带有一个数组。
您只需要对输出进行排序吗？
@rickmanalexander WorksheetFunction.CountIf 确实接受 Range 对象作为第一个参数。你不能先设置一个 Range 对象吗？
@RyanWildry 我不能使用Range 对象。我正在处理内存中的所有内容，因为我将recordset 从SQL 复制到Source_Array，查看数组的某些列，然后根据多个条件更改它们的值。其中一个需要使用一些函数来计算重复的数量作为发生/即运行重复的总数，如下所示：Mod(count of the number of duplicates as the occur/ i.e.running total of the duplicates) = 0，然后根据需要对它们进行分类。

标签： arrays excel vba dictionary duplicates

【解决方案1】：

你能用第二个数组吗？

Option Explicit
Sub DuplicateOccrencesCount()

Dim Source_Array
Dim result_array
Dim dict As Object
Dim i As Long
Dim colIndex As Integer

colIndex = 26

Set dict = CreateObject("Scripting.dictionary")

 Source_Array = Sheet2.Range("A2").CurrentRegion.Value2
Redim result_array(lbound source_array,1) to ubound(source_array,1),1 to 1)


For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
    If dict.Exists(Source_Array(i, colIndex)) Then
        dict.Item(Source_Array(i, colIndex)) = dict.Item(Source_Array(i, colIndex)) + 1
    Else
        dict.Add Source_Array(i, colIndex), 1
    End If

    Result_array(I,1) = dict.Item(Source_Array(i, colIndex))
Next i

    Sheet9.Range("A2").Resize(dict.Count, 1).Value = _
    WorksheetFunction.Transpose(dict.keys)
    Sheet9.Range("B2").Resize(dict.Count, 1).value = result_array

End Sub

有时我会走捷径并在获取范围值时抓取两列，然后将第二列用于结果。

【讨论】：

在你发布这个大声笑之前，我昨晚大约晚上 7 点才这样做！请参阅我的帖子中的更新 1 和 2。

【解决方案2】：

经过反复试验，我想出了以下几点：

Sub GetRunningCounts()
  Dim dict As Object
  Dim i As Long
  Dim Source_Array, OutPut_Array

  Set dict = CreateObject("Scripting.Dictionary")

  Source_Array = Sheet2.Range("A2").CurrentRegion.Value2

  ReDim OutPut_Array(LBound(Source_Array, 1) To UBound(Source_Array, 1), 1 To 1)

  For i = LBound(Source_Array, 1) To UBound(Source_Array, 1)
     dict(Source_Array(i, 26)) = dict(Source_Array(i, 26)) + 1
     OutPut_Array(i, 1) = dict(Source_Array(i, 26))
  Next i

  Sheet9.Range("B1").Resize(UBound(OutPut_Array, 1)).Value = OutPut_Array

End Sub

我随后将其转换为 UDF，如下所示：

Function RunningCntOfOccsInArr(ByRef Source_Array As Variant, ByRef RowIndex As Long, ByVal ColIndex As Integer) As Variant

 Dim dict As Object
 Dim OutPut_Array As Variant

    Set dict = CreateObject("Scripting.Dictionary")

    ReDim OutPut_Array(LBound(Source_Array, 1) To UBound(Source_Array, 1), 1 To 1)

    For RowIndex = LBound(Source_Array, 1) To UBound(Source_Array, 1)
        dict(Source_Array(RowIndex, ColIndex)) = dict(Source_Array(RowIndex, ColIndex)) + 1
        OutPut_Array(RowIndex, 1) = dict(Source_Array(RowIndex, ColIndex))
    Next RowIndex

    RunningCntOfOccsInArr = OutPut_Array

End Function

这是一个在子过程中使用它的例子。 @TateGarringer 在this 帖子中提供了这个实现。

Sub Test_GetRunningCounts()
  Dim i As Long
  Dim i2 As Long
  Dim Data_Array
  Dim returnArray() As Variant

  Application.ScreenUpdating = False

  Data_Array = Sheet1.Range("A2").CurrentRegion.Value2
    For i = LBound(Data_Array, 1) To UBound(Data_Array, 1)
        returnArray = RunningCntOfOccsInArr(Data_Array, i, 21)
        For i2 = LBound(returnArray) To UBound(returnArray)
            If returnArray(i2, 1) Mod 2 = 0 Then
                  Sheet2.Cells(i, 2).Value2 = "Even"
            Else
                  Sheet2.Cells(i, 2).Value2 = "Odd"
            End If
        Next i2
    Next i

    Sheet2.Range("A1").Resize(UBound(returnArray, 1)).Value = returnArray
End Sub

【讨论】：