Conditional removal of duplicates

[sucram3]

Hi,

I want to sort a column by removing duplicates, but not all duplicates, only those that appear in sequence, i.e:

1
2
3
3 (I want this removed)
4
2
3
2
2 (I want this removed)
3
4
4 (I want this removed)

Reason for this is that I'm trying to build a tree structure where various instances are used on different places in the structure, but not after each other.

I have searched this forum but haven't found anything that helps.

Thanks.

 

[sucram3]

Hi
What about

Sub test()
Dim a: Dim c&, i&
    c = 1
    a = Range(Cells(1, 1), Cells(1, 1).End(xlDown))
    ReDim b(1 To UBound(a))
    For i = 1 To UBound(a) - 1
        If a(i + 1, 1) <> a(i, 1) Then b(c) = a(i + 1, 1):   c = c + 1
    Next
Cells(2, 2).Resize(c) = Application.Transpose(b)
End Sub

Heder
1​	1​
2​	2​
3​	3​
3​	4​
4​	2​
2​	3​
3​	2​
2​	3​
3​	4​
4​
4​

Hi!

Thank you for this.

In the end I used the filter formula which was proposed a few posts earlier in this thread.

Thank you for taking your time.

BR

 

[Joe4]

I tried this code and had it running for a while, and while testing 200 rows, it worked great. Although when running it on the complete set, all 250000 rows, it appeared to be a bit time consuming.

I'm so grateful for your time, despite my workbook being a bit too big.

Thank you.

BR

That is to be expected, if you are looping through that many rows! Excel is usually not the tastest tool when working with massive amounts of data.

I don't know if it will make any difference, but you can see if these minor edits help speed it up at all (they certainly won't make it any slower):

Sub MyDeleteDups()

    Dim lr As Long
    Dim r As Long
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
   
'   Find last row in column D with data
    lr = Cells(Rows.Count, "D").End(xlUp).Row
   
'   Loop through all rows backwards
    For r = lr To 17 Step -1
'       Delete current row if value in column D same as value above it
        If Cells(r, "D").Value = Cells(r - 1, "D").Value Then Rows(r).Delete
    Next r
   
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
   
End Sub