[英]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.
许多PO都是重复的,我有一个要检查的条件列表,其中之一是重复PO发生时的计数。 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 . 但是我需要按字典中出现顺序的顺序来确定每个重复键的出现次数,以匹配上面提到的帖子中
COUNTIF
的功能。 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: 我想到了使用某种方法来查找循环中
Source_array
当前行索引处的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
However when the condition is true and the array is printed out to the sheet, Source_Array(i,30)
is Blank for all rows. 但是,当条件为true且将数组打印到工作表上时,所有行的
Source_Array(i,30)
均为空白。
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 更新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
UPDATE 2: After several more hours of trial and error last night I came up with the following revision: 更新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
Which I subsequently converted to a UDF as follows: 随后我将其转换为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
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. 有时,我会使用快捷方式并在获得范围值时抓住两列,然后将第二列用于结果。
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: 随后我将其转换为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
Here is an example of its use in a Sub Procedure. 这是在子过程中使用它的示例。 @TateGarringer Provided this implementation in this post.
@TateGarringer在这篇文章中提供了此实现。
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.