Improve Cycles data with Excel VBA

Question

I need help to improve this code because it is slow to execute it with a lot of data.

The problem is that I have a table, where recursive data appear, and I have to delete only one of them. This is an example, in this table, as you can see, there may be cyclical data:

For that reason, concatenate in columns D and E, to copy D in F column, then find F value at E column, and delete entire row if found it.

I did it in this way, because otherwise, I deleted both cyclicals and I need to keep one. It is repeated until macro find a blank cell in column A. Here is the code I wrote:

Sub CycleFind3()

    Dim rFound As Range
    Dim lookfor As String
    Dim xCell As Range

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Sheets("LOCID").Select
DoItAgain:
    Range("A1").Select
    ' Select empty cell on F and move to A to verify if its empty
    For Each xCell In ActiveSheet.Columns(6).Cells
        If Len(xCell) = 0 Then
            xCell.Select
            Exit For
        End If
    Next
    ActiveCell.Offset(0, -5).Select
    If Not IsEmpty(ActiveCell.Value) Then
    Else
        Exit Sub ' if Axx is empty, exit the sub
    End If
    ' Select last cell used in G
    Range("F1048576").Select
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    ' then copy D value
    ActiveCell.Offset(0, -2).Copy
    ActiveCell.PasteSpecial
    Application.CutCopyMode = False
    ' looking for F value at E column
    lookfor = ActiveCell
    Set rFound = ActiveSheet.Range("E:E").Find(What:=lookfor, LookIn:= _
        xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
        xlNext, MatchCase:=False, SearchFormat:=False)
    If rFound Is Nothing Then
        ' if not found start again to do the same to follow row
        GoTo DoItAgain
    Else
        ' If find F in E delete row
        rFound.Select
        ActiveCell.EntireRow.Delete
    End If
    ' repeat until A is blank cell
    GoTo DoItAgain

End Sub

How can I improve to optimize the execution time?

Answer 1

I believe you are over-thinking the process and over-processing the method.

If you take an array of the first three columns and build a single fourth concatenated column from the first three, you might have some duplicates if C-A-B was compared to C-B-A. However, if you build the concatenated column with the first two columns sorted then C-A-B and C-B-A both produce the same result.

Option Explicit

Sub cycleFind4()
    Dim i As Long, j As Long, arr As Variant, val As Variant

    With Worksheets("LOCID")

        'collect values from worksheet
        arr = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "C").End(xlUp)).Value2

        'add an extra 'column' to the array
        ReDim Preserve arr(LBound(arr, 1) To UBound(arr, 1), _
                           LBound(arr, 2) To UBound(arr, 2) + 1)

        'populate a single laterally-sorted concat field
        For i = LBound(arr, 1) To UBound(arr, 1)
            If CStr(arr(i, 1)) < CStr(arr(i, 2)) Then
                arr(i, 4) = Join(Array(arr(i, 3), arr(i, 1), arr(i, 2)), vbNullString)
            Else
                arr(i, 4) = Join(Array(arr(i, 3), arr(i, 2), arr(i, 1)), vbNullString)
            End If
        Next i

        'return array to worksheet
        .Cells(2, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr

        'remove duplicates from bottom-to-top
        With .Cells(1, "A").CurrentRegion
            .RemoveDuplicates Columns:=Array(4), Header:=xlYes
        End With
    End With
End Sub

~47K records processed in about one second.