Question

我有一个带有采购订单列的数据集。许多PO都是重复的，我有一个要检查的条件列表，其中之一是重复PO发生时的计数。我很难找到确切的方法来修改我的代码。基本上，我需要做的事情就是像this post

中的公式一样对出现的次数进行计数

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

FILENAME = 'C:\select your database location\deneme1db.mdf

但是，我需要每个重复键的出现次数才能按照字典的出现顺序进行构建，以匹配post mentioned above中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当前行索引处的值是否重复，然后增加一个计数器，如下所示：

Source_array

但是，当条件为true并且数组被打印到工作表时，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对于所有行都是空白。

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

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

Source_Array(i,30)

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

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

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

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

Answer 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

有时，我会使用快捷方式并在获得范围值时抓住两列，然后将第二列用于结果。

Answer 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

VBA：计算重复项的发生顺序

2 个答案: