VBA: Count The Order Of Occurrence Of Duplicates

问题

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

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

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.

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

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

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

回答1:

Can you use a second array?

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

Sometimes I take a shortcut and grab two columns when I get the range values, then use the second column for the results.

回答2:

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

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

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

来源：https://stackoverflow.com/questions/54079904/vba-count-the-order-of-occurrence-of-duplicates

标签

arrays

excel

vba

dictionary

duplicates