VBA:计算重复项的发生顺序 [英] VBA: Count The Order Of Occurrence Of Duplicates

问题描述

我有一个带有采购订单"列的数据集.许多PO都是重复的，我有一个要检查的条件列表，其中之一是重复PO发生时的计数.我很难找到确切的方法来修改我的代码.基本上，我所需要做的就是对发生的次数进行计数，就像这篇文章

I have a dataset with a column of Purchase Orders. Many of the PO's are duplicates and I have a list of conditions that I am checking against, one of which, is the count of the duplicate PO's as they occur. I am having trouble discovering exactly how to modify my code to do so. Basically all I need is a something to count occurrences exactly like the formula in this post

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

So far I have code that counts the total of duplicate items per Key as follows:

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

但是，我需要每个重复键的出现次数才能按字典的顺序排列，以匹配COUNTIF的功能Questions/37426298/count-duplicates-and-display-of-occurrence>上面提到的帖子.我想到了要使用某种方法来查找循环中Source_array当前行索引处的值是否重复，然后增加一个计数器，如下所示:

However I need the number of occurrences per duplicate key in order of occurrence in the dictionary as it is built in order to match the functionallity of the COUNTIF in the post mentioned above. I thought of using something to find if the value at the current row index of Source_array within a loop is a duplicate and then increasing a counter Like so:

 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

但是，当条件为true且将数组打印到工作表上时，对于所有行，Source_Array(i,30)为空白.

However when the condition is true and the array is printed out to the sheet, Source_Array(i,30) is Blank for all rows.

任何想法，想法或答案将不胜感激.

Any thoughts, ideas, or answers would be greatly appreciated.

更新1:经过反复试验，我提出了以下计划实现功能的方法

UPDATE 1: After trial and error, I came up with the following which I plan to make a function

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:昨晚经过数小时的反复试验，我提出了以下修订版本:

UPDATE 2: After several more hours of trial and error last night I came up with the following revision:

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:

Which I subsequently converted to a UDF as follows:

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

推荐答案

经过反复试验，我提出了以下建议:

After trial and error, I came up with the following:

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:

Which I subsequently converted to a UDF as follows:

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在此帖子中提供了此实现.

Here is an example of its use in a Sub Procedure. @TateGarringer Provided this implementation in this post.

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

这篇关于VBA:计算重复项的发生顺序的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！