Macro has long runningtime

How about this?

Sub AddActive()
    Dim Rng As Range
    Dim i As Long
    Application.ScreenUpdating = False
    'Looping range
    Set Rng = Sheets("WorkingSheet").Range("AA11:AA1008")
    
    With Sheets("Overview")
        For Each cell In Rng
            If cell.Value = "NO" Then
               
                'write to adjacent cell
                .Cells(1001, "A").End(xlUp).Offset(1).Resize(, 6).Value = _
                    Array(cell.Offset(0, -24).Value, cell.Offset(0, -23).Value, cell.Offset(0, -22).Value, _
                    cell.Offset(0, -21).Value, cell.Offset(0, -20).Value, cell.Offset(0, -18).Value)
                
            End If
        Next
    End With
    
    Application.ScreenUpdating = True
End Sub

You may try the remove duplicates function in Excel itself. If this doesn't work then let's modify your existing macro.

Sub Duplicate()

     'Change "G" to the last column of data you have.
    Sheets("overview").Range("A36:G" & Sheets("overview").Range("A" & rows.count).End(xlUP).row).RemoveDuplicates Columns:=1, Header:=xlYes
    
End Sub

Were there any errors?

How many rows of data is (usually) involved in the removal of duplicates?

Would the number of rows ever exceed 32000?

Originally Posted by madsklavsen

This is the error i get:
Attachment 470439

The error is because you have entered the code wrongly.

Try this, just copy and paste the whole code:

Sub Duplicate()

     'Change "G" to the last column of data you have.
    Sheets("overview").Range("A35:H" & Sheets("overview").Range("A" & rows.count).End(xlUP).row).RemoveDuplicates Columns:=1, Header:=xlYes
    
End Sub

Hi,

It would likely be considerably faster to use an array rather than reading each cell and further to delete all relevant rows at once.

Sub DeDuplicate()

    Dim objMyUniqueEntries    As Object
    Dim vtEntries             As Variant
    Dim lngRowStart           As Long, _
        lngRowEnd As Long, _
        lngMyRow As Long, _
        lngMyCounter As Long, _
        lngOffset As Long, _
        ix As Long
    Dim RowsToDelete          As Range

    Set objMyUniqueEntries = CreateObject("Scripting.Dictionary")
    lngRowStart = 36    'Starting row number for the data. Change to suit.
    lngOffset = lngRowStart - 1

    Application.ScreenUpdating = False
    With Sheets("overview")
        lngRowEnd = .Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        vtEntries = .Range(.Cells(lngRowStart, "A"), .Cells(lngRowEnd, "A")).Value2
        For ix = UBound(vtEntries) To LBound(vtEntries) Step -1

            If Not objMyUniqueEntries.exists(vtEntries(ix, 1)) Then
                objMyUniqueEntries.Add vtEntries(ix, 1), Empty
            Else
                If RowsToDelete Is Nothing Then
                    Set RowsToDelete = .Rows(ix + lngOffset)
                Else
                    Set RowsToDelete = Union(RowsToDelete, .Rows(ix + lngOffset))
                End If
            End If
        Next ix
    End With
    
    If Not RowsToDelete Is Nothing Then RowsToDelete.EntireRow.Delete
    
    Set objMyUniqueEntries = Nothing

    Application.ScreenUpdating = True

End Sub

Originally Posted by madsklavsen

What the beforestated macro does is delete the row of the duplicate AND delete the first appearance of a duplicate instead of the last. Both of these features are vital.

Please let me know if you have any ideas. Thanks!

I have corrected the suggestion I made earlier to loop backwards.

I see, did not know that there's a requirement to keep only the last duplicate record.

This solution replaces with values (no deletion of rows), so it could be faster:

Sub Duplicate()

    Dim objMyUniqueEntries As Object
    Dim lngRowStart As Long, _
        lngRowEnd As Long, _
        lngMyRow As Long, _
        lngMyCounter As Long
    Dim a, b, i As Long
    Sheets("overview").Select
    Set objMyUniqueEntries = CreateObject("Scripting.Dictionary")
    lngRowStart = 36 'Starting row number for the data. Change to suit.
    lngRowEnd = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

    Application.ScreenUpdating = False

    With Sheets("overview").Range("A" & lngRowStart & ":H" & lngRowEnd)
        a = .Value
        For lngMyRow = UBound(a, 1) To LBound(a, 1) Step -1
            If Not objMyUniqueEntries.Exists(a(lngMyRow, 1)) And a(lngMyRow, 1) <> "" Then
                lngMyCounter = lngMyCounter + 1
                objMyUniqueEntries.Item(a(lngMyRow, 1)) = 1
            End If
        Next lngMyRow
        ReDim b(1 To lngMyCounter, 1 To UBound(a, 2))
        For lngMyRow = UBound(a, 1) To LBound(a, 1) Step -1
            If objMyUniqueEntries.Exists(a(lngMyRow, 1)) Then
                objMyUniqueEntries.Remove (a(lngMyRow, 1))
                For i = LBound(a, 2) To UBound(a, 2)
                    b(lngMyCounter, i) = a(lngMyRow, i)
                Next
                lngMyCounter = lngMyCounter - 1
            End If
        Next lngMyRow
        .ClearContents
        .Resize(UBound(b, 1)).Value = b
    End With

    Set objMyUniqueEntries = Nothing

    Application.ScreenUpdating = True

End Sub