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?

First of all, do not use `Selection`, `ActiveCell` properties, and `.Select`, `.Copy`, `.PasteSpecial` methods. Assign a range to a variable instead of `.Select` method call on that range. Use that variable instead of `Selection`, `ActiveCell`. Read from a cell and write to using cell `.Value` property instead of `.Copy`, `.PasteSpecial`. — omegastripes, Aug 04 '18 at 01:07
Thank you omegastripes for your quick response. Could you give me a brief example? Thank you! — Lucali, Aug 04 '18 at 01:18

omegastripes · Answer 1 · 2018-08-04T15:56:02.880

Consider the below example:

Option Explicit

Sub CycleFind3()

    Dim rFound As Range
    Dim sLookfor As String
    Dim rCell As Range

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    With Sheets("LOCID")
        .Select
        Do
            ' Repeat until A is blank cell
            For Each rCell In .Columns(6).Cells
                ' Get empty cell on F and verify if A is empty
                If IsEmpty(rCell.Value) Then
                    ' If A is empty, exit the sub
                    If IsEmpty(rCell.Offset(0, -5).Value) Then Exit Do
                    Exit For
                End If
            Next
            ' Last cell used in F
            With .Range("F1048576").End(xlUp).Offset(1, 0)
                ' Get D value
                sLookfor = .Offset(0, -2).Value
                .Value = sLookfor
            End With
            ' Looking for F value at E column
            Set rFound = .Range("E:E").Find(What:=sLookfor, LookIn:= _
                xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
                xlNext, MatchCase:=False, SearchFormat:=False)
            If Not rFound Is Nothing Then
                ' If find F in E delete row
                rFound.EntireRow.Delete
            End If
        Loop
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

GREAT @omegastripes!!! Thank you very very much for your help. However, it is still 47000 rows the execution is slow. I think I will first look for duplicate cycles, and execute the code based on those previously found duplicates. If in the future there are more errors, I calculate that for 700 rows it takes approximately 1 minute, I do not think there are 49000 errors ... I hope ... Thank you — Lucali, Aug 04 '18 at 03:25
You should drop .Select off lines like `With .Range("F1048576").End(xlUp).Offset(1, 0).Select` — , Aug 04 '18 at 04:34

score 0 · Answer 2 · answered Aug 04 '18 at 03:35

This is my last modification code, thanks to @omegastripes

Sub CycleFind3()

    Dim rFound As Range
    Dim sLookfor As String
    Dim rCell As Range
    Dim rowFlast As Long
    Dim rowF As Range

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    With Sheets("LOCID")
        .Select
        Do
            ' Repeat until A is blank cell
            For Each rCell In .Columns(6).Cells
                ' Get empty cell on F and verify if A is empty
                If IsEmpty(rCell.Value) Then
                    ' If A is empty, exit the sub
                    If IsEmpty(rCell.Offset(0, -5).Value) Then Exit Do
                    Exit For
                End If
            Next
            ' Last cell used in F
    rowFlast = Cells(Rows.Count, 6).End(xlUp).Row + 1
    Set rowF = Range(Cells(rowFlast, 6), Cells(rowFlast, 6))
            With rowF.Select
                ' Get D value
      sLookfor = rowF.Offset(0, -2).Value
            rowF.Value = sLookfor
           End With
            ' Looking for F value at E column
            Set rFound = .Range("E:E").Find(What:=sLookfor, LookIn:= _
                xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:= _
                xlNext, MatchCase:=False, SearchFormat:=False)
            If Not rFound Is Nothing Then
                ' If find F in E delete row
                rFound.EntireRow.Delete
            End If
        Loop
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True

End Sub

The expression `rowF.Select` is wrong and should be just `rowF`, also `With ... End With` is not necessary in that context at all, and should be removed. — omegastripes, Aug 04 '18 at 16:03

score 0 · Accepted Answer · 2018-08-05T01:44:06.807

0

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.

edited Aug 05 '18 at 01:44

answered Aug 04 '18 at 07:49

Wow ... without words ... I had not thought about it that way, anyway your code is amazing. I'm not a programmer and I'm putting together code as they go. A thousand thanks, this way really fast and with this and tips provided by @omegastripes it teaches me to improve other parts of my macro. Thank you very much for your time really – Lucali Aug 05 '18 at 01:26
Yeah, arrays and in-memory processing is the only way to go with bulk data. Last week both myself and another 'answerer' came up with array methods that changed processing 150K records from 1 hour (with frozen machine) to less than 1 second. – Aug 05 '18 at 01:41
I actually did look for it but I respond to so many question each day I found it difficult to locate. If it's important to you I'll check again when I have some time, perhaps in a half hour or so. – Aug 05 '18 at 02:32
I do not find how to send a private message by this means, but I would like to see that work. Where are you from? – Lucali Aug 05 '18 at 03:05
You cannot send private messages in this Q&A site but you can ping @Lucali or force ping @@Lucali to leave notification of a public message. That doesn't mean that anyone is obligated to respond. The thread I was referring to was [here](https://stackoverflow.com/questions/51565491/delete-blank-cells-146-459-rows/51573727?s=1|0.0000#51573727). – Aug 05 '18 at 03:41

Improve Cycles data with Excel VBA

3 Answers3