CODEWITHSUNDEEP
vbaexcel
Leo
Leo

Reputation: 1254

Fast merging duplicates in excel using VBA

I created a macro in Excel to mergue duplicated rows:

The idea is that if 2 rows or more have the same A B C columns, I mergue their D columns removing ABC duplicates. I need to do this, but checking more colums.

My macro looks like this:

processingRow = 2
Do Until Cells(processingRow, 1).Value = ""
    i = processingRow + 1

    Do Until Cells(i, 1).Value = ""
       If Cells(processingRow, 8) = Cells(i, 8) And _
          Cells(processingRow, 12) = Cells(i, 12) And _
          Cells(processingRow, 7) = Cells(i, 7) And _
          Cells(processingRow, 6) = Cells(i, 6) And _
          Cells(processingRow, 5) = Cells(i, 5) And _
          Cells(processingRow, 4) = Cells(i, 4) And _
          Cells(processingRow, 3) = Cells(i, 3) And _
          Cells(processingRow, 2) = Cells(i, 2) And _
          Cells(processingRow, 1) = Cells(i, 1) Then
               If Cells(i, 14) <> "" Then
                    Cells(processingRow, 14) = Cells(processingRow, 14) & "," & Cells(i, 14)
               End If
               Rows(i).Delete


        End If
        i = i + 1
    Loop

    processingRow = processingRow + 1

Loop

When running the macro with 500 rows, it takes a while, but its still reasonable. But I need to run this macro in a excel with more than 2500 rows, and it takes so much time that its not practical anymore.

This is my first macro in excel using VBA, so I was wondering if there is a faster way to process rows/cells, since accessing them individually seems extremelly slow.

Any ideas?

Upvotes: 0

Views: 1313

Answers (1)

Tim Williams
Tim Williams

Reputation: 166146

EDITED: I missed that you weren't checking every column to determine what was a duplicate. This should be closer now:

Sub Tester()

Dim rngCheck As Range, rw As Range
Dim dict As Object, k As String, rwDup As Range
Dim rngDel As Range, tmp

    Set dict = CreateObject("scripting.dictionary")

    With ActiveSheet
        Set rngCheck = .Range(.Cells(2, 1), _
                              .Cells(Rows.Count, 1).End(xlUp)).Resize(, 14)
    End With

    For Each rw In rngCheck.Rows

        k = RowKey(rw)
        If dict.exists(k) Then
            Set rwDup = dict(k)
            tmp = rw.Cells(14).Value
            If Len(tmp) > 0 Then
                rwDup.Cells(14).Value = rwDup.Cells(14).Value & "," & tmp
            End If
            If rngDel Is Nothing Then
                Set rngDel = rw
            Else
                Set rngDel = Application.Union(rngDel, rw)
            End If
        Else
            dict.Add k, rw
        End If

    Next rw

    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete
End Sub

'create a "key" for the row by joining all columns to be checked
Function RowKey(rw As Range) As String
    Dim arr, x As Long, sep As String, rv As String
    arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 12)
    For x = LBound(arr) To UBound(arr)
        rv = rv & sep & rw.Cells(arr(x)).Value
        sep = Chr(0)
    Next x
    RowKey = rv
End Function

Upvotes: 1

Related Questions