VBA: считать порядок появления дубликатов - PullRequest
Новая
       7

VBA: считать порядок появления дубликатов

0 голосов
/ 07 января 2019

У меня есть набор данных с колонкой заказов на покупку. Многие из PO являются дубликатами, и у меня есть список условий, по которым я проверяю, одним из которых является количество дубликатов PO по мере их появления. У меня проблемы с поиском, как именно изменить мой код, чтобы сделать это. По сути, все, что мне нужно, это что-то, чтобы считать события в точности как формула в этом посте

Пока у меня есть код, который подсчитывает общее количество повторяющихся элементов на ключ следующим образом: 

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 в цикле дубликатом, а затем увеличить счетчик. Вот так: 

 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

Ответы [ 2 ]

0 голосов
/ 09 января 2019

После проб и ошибок я придумал следующее: 

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 Предоставил эту реализацию в этом посте. 

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
0 голосов
/ 08 января 2019

Можете ли вы использовать второй массив? 

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

Иногда я беру ярлык и беру два столбца, когда получаю значения диапазона, а затем использую второй столбец для результатов.

...