Нужна помощь в оптимизации кода Excel VBA, который объединяет дубликаты

Question

Ниже моя исходная таблица

    Name              Sales
---------------------------------
    Thomas             100
    Jay                200
    Thomas             100
    Mathew              50

Вывод мне нужен, как показано ниже

    Name              Sales
---------------------------------
    Thomas             200
    Jay                200
    Mathew              50

В принципе, у меня есть 2 столбца, которые могут иметь дубликаты, и мне нужно объединить второй столбецосновано на первом столбце.

Текущий код, который я имею, как показано ниже.Работает отлично.На 4500 записей уходит около 45 секунд.Мне было интересно, есть ли более эффективный способ сделать это ... поскольку это кажется тривиальным требованием.

'Combine duplicate rows and sum values

Dim Rng As Range
Dim LngRow As Long, i As Long

LngLastRow = lRow 'The last row is calculated somewhere above...

'Initializing the first row
i = 1

'Looping until blank cell is encountered in first column
While Not Cells(i, 1).Value = ""

    'Initializing range object
    Set Rng = Cells(i, 1)

    'Looping from last row to specified first row
    For LngRow = LngLastRow To (i + 1) Step -1

        'Checking whether value in the cell is equal to specified cell
        If Cells(LngRow, 1).Value = Rng.Value Then
            Rng.Offset(0, 1).Value = Rng.Offset(0, 1).Value + Cells(LngRow, 2).Value
            Rows(LngRow).Delete
        End If

    Next LngRow

    i = i + 1

Wend

Обратите внимание, что это часть большего приложения Excel, и, следовательно, мне определенно нужнорешение находиться в Excel VBA.

Answer 1

С данными в столбцах A и B как:

Запуск этого короткого макроса:

Sub KopyII()
    Dim cell As Range, N As Long

    Columns("A:A").Copy Range("C1")
    ActiveSheet.Range("C:C").RemoveDuplicates Columns:=1, Header:=xlNo
    N = Cells(Rows.Count, "C").End(xlUp).Row

    Range("B1").Copy Range("D1")

    Range("D2:D" & N).Formula = "=SUMPRODUCT(--(A:A= C2),(B:B))"
End Sub

будет производить это в столбцах C и D :

Примечание:

Это зависит от встроенной в Excel функции RemoveDuplicates.

EDIT # 1:

Как указывает Крис Нилсен, эта функция должна быть немного быстрее оценена:

Sub KopyIII()
    Dim cell As Range, N As Long, A As Range, C As Range
    Set A = Range("A:A")
    Set C = Range("C:C")

    A.Copy C
    C.RemoveDuplicates Columns:=1, Header:=xlNo
    N = Cells(Rows.Count, "C").End(xlUp).Row

    Range("B1").Copy Range("D1")  ' the header

    Range("D2:D" & N).Formula = "=SUMIFS(B:B,A:A,C2)"
End Sub

Answer 2

Вот, пожалуйста:

Option Explicit
Sub Consolidate()

    Dim arrData As Variant
    Dim i As Long
    Dim Sales As New Scripting.Dictionary 'You will need the library Microsoft Scripting Runtime

    Application.ScreenUpdating = False 'speed up the code since excel won't show you what is happening

    'First of all, working on arrays always speeds up a lot the code because you are working on memory
    'instead of working with the sheets
    With ThisWorkbook.Sheets("YourSheet") 'change this
        i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
        arrData = .Range("A2", .Cells(i, 2)).Value 'here im assuming your row 1 has headers and we are storing the data into an array
    End With

    'Then we create a dictionary with the data
    For i = 1 To UBound(arrData) 'from row 2 to the last on Q1 (the highest)
        If Not Sales.Exists(arrData(i, 1)) Then
            Sales.Add arrData(i, 1), arrData(i, 2) 'We add the worker(Key) with his sales(Item)
        Else
            Sales(arrData(i, 1)) = Sales(arrData(i, 1)) + arrData(i, 2) 'if the worker already exists, sum his sales
        End If
    Next i

    'Now you have all the workers just once
    'If you want to delete column A and B and just leave the consolidate data:
    With ThisWorkbook.Sheets("YourSheet") 'change this
        i = .Cells(.Rows.Count, 1).End(xlUp).Row 'last row on column A
        .Range("A2:B" & i).ClearContents
        .Cells(2, 1).Resize(Sales.Count) = Application.Transpose(Sales.Keys) 'workers
        .Cells(2, 2).Resize(Sales.Count) = Application.Transpose(Sales.Items) 'Their sales
    End With

    Application.ScreenUpdating = True 'return excel to normal

End Sub

Чтобы узнать все о словарях (и не только), отметьте this