Sort duplicates in the column

T

topi1

Active Member
Joined
Aug 6, 2014
Messages
252
Office Version
  1. 2010
I need vba to sort rows based on a column as follows.
There are sets of duplicates in the column. Case-insensitive. There are blank cells in the column.
vba to sort so that the duplicates are in the adjacent rows, otherwise keeping their original order.
Remaining cells retain same order as before.
Thank you in advance.
 
Sort by date Sort by votes
Yes please. Based on column O, sort entire data. Delete entire rows and not just cells. Thanks.
 
Upvote 0

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
topi1 said:
Yes please. Based on column O, sort entire data. Delete entire rows and not just cells. Thanks.
Click to expand...
Try this one:
VBA Code: 
Sub topi1_4()
Dim i As Long, n As Long, h As Long, k As Long
Dim va, vb
Dim d As Object, e As Object

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
Set e = CreateObject("scripting.dictionary"): e.CompareMode = vbTextCompare
va = Range("O1", Cells(Rows.Count, "O").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)
For i = 1 To UBound(va, 1)
    If Not d.Exists(va(i, 1)) Then
        n = n + 1
        d(va(i, 1)) = n
        vb(i, 1) = n
    Else
        vb(i, 1) = d(va(i, 1))
        e(va(i, 1)) = ""
    End If
Next
h = e.Count
For i = 1 To UBound(va, 1)
    If e.Count = 0 Then Exit For
    If e.Exists(va(i, 1)) Then
        vb(i, 1) = ""
        e.Remove va(i, 1)
    End If
Next

'using col T as temporary helper column
Range("T1").Resize(UBound(vb, 1), 1) = vb
Range("A:T").Sort Key1:=Range("T1"), Order1:=xlAscending, Header:=xlNo
k = Range("T" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h).EntireRow.ClearContents
Range("T:T").ClearContents
End Sub
 
Upvote 0
Akuini said:
Try this one:
VBA Code: 
Sub topi1_4()
Dim i As Long, n As Long, h As Long, k As Long
Dim va, vb
Dim d As Object, e As Object

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
Set e = CreateObject("scripting.dictionary"): e.CompareMode = vbTextCompare
va = Range("O1", Cells(Rows.Count, "O").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)
For i = 1 To UBound(va, 1)
    If Not d.Exists(va(i, 1)) Then
        n = n + 1
        d(va(i, 1)) = n
        vb(i, 1) = n
    Else
        vb(i, 1) = d(va(i, 1))
        e(va(i, 1)) = ""
    End If
Next
h = e.Count
For i = 1 To UBound(va, 1)
    If e.Count = 0 Then Exit For
    If e.Exists(va(i, 1)) Then
        vb(i, 1) = ""
        e.Remove va(i, 1)
    End If
Next

'using col T as temporary helper column
Range("T1").Resize(UBound(vb, 1), 1) = vb
Range("A:T").Sort Key1:=Range("T1"), Order1:=xlAscending, Header:=xlNo
k = Range("T" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h).EntireRow.ClearContents
Range("T:T").ClearContents
End Sub
Click to expand...
It works like a charm!! I thank you very much!
 
Upvote 0
You're welcome, glad to help & thanks for the feedback.:)
 
Upvote 0
@Akuini The following code you gave me works great. But it deletes the first row. Is it based on some header condition? There are no header rows and can you please modify it so the first row is not deleted? Thank you.


VBA Code: 
Sub topi1_4()
Dim i As Long, n As Long, h As Long, k As Long
Dim va, vb
Dim d As Object, e As Object

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
Set e = CreateObject("scripting.dictionary"): e.CompareMode = vbTextCompare
va = Range("O1", Cells(Rows.Count, "O").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)
For i = 1 To UBound(va, 1)
    If Not d.Exists(va(i, 1)) Then
        n = n + 1
        d(va(i, 1)) = n
        vb(i, 1) = n
    Else
        vb(i, 1) = d(va(i, 1))
        e(va(i, 1)) = ""
    End If
Next
h = e.Count
For i = 1 To UBound(va, 1)
    If e.Count = 0 Then Exit For
    If e.Exists(va(i, 1)) Then
        vb(i, 1) = ""
        e.Remove va(i, 1)
    End If
Next

'using col T as temporary helper column
Range("T1").Resize(UBound(vb, 1), 1) = vb
Range("A:T").Sort Key1:=Range("T1"), Order1:=xlAscending, Header:=xlNo
k = Range("T" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h).EntireRow.ClearContents
Range("T:T").ClearContents
End Sub
 
Upvote 0
@Akuini Sorry. was asleep when you requested. Here are the examples. Notice how top cell with value of 1 has been deleted in the AFTER file. I don't want any cell like that where O column is blank not to be deleted (DESIRED file). Thank you for your help. (Please ignore red font in BEFORE).

BEFORE

Only necessary VBA.xlsm
OPQR
11
22
33
4B4
5A5
6X6
7A7
8A8
9B9
10C10
11D11
12A12
13D13
14B14
Sheet2


AFTER

Only necessary VBA.xlsm
OPQR
12
23
3B9
4B14
5A7
6A8
7A12
8X6
9C10
10D13
Sheet2


DESIRED

Only necessary VBA.xlsm
OPQR
11
22
33
4B9
5B14
6A7
7A8
8A12
9X6
10C10
11D13
Sheet2
 
Upvote 0
topi1 said:
I don't want any cell like that where O column is blank not to be deleted (DESIRED file).
Click to expand...
Are the empty cells in column O always located at the top?
VBA Code: 
Sub topi1_5()
Dim i As Long, n As Long, h As Long, k As Long
Dim va, vb
Dim d As Object, e As Object

Set d = CreateObject("scripting.dictionary"): d.CompareMode = vbTextCompare
Set e = CreateObject("scripting.dictionary"): e.CompareMode = vbTextCompare
va = Range("O1", Cells(Rows.Count, "O").End(xlUp))
ReDim vb(1 To UBound(va, 1), 1 To 1)
For i = 1 To UBound(va, 1)
    If va(i, 1) = "" Then
        vb(i, 1) = 0
    Else
        If Not d.Exists(va(i, 1)) Then
            n = n + 1
            d(va(i, 1)) = n
            vb(i, 1) = n
        Else
            vb(i, 1) = d(va(i, 1))
            e(va(i, 1)) = ""
        End If
    End If
Next
h = e.Count
For i = 1 To UBound(va, 1)
    If e.Count = 0 Then Exit For
    If e.Exists(va(i, 1)) Then
        vb(i, 1) = ""
        e.Remove va(i, 1)
    End If
Next

'using col T as temporary helper column
Range("T1").Resize(UBound(vb, 1), 1) = vb
Range("A:T").Sort Key1:=Range("T1"), Order1:=xlAscending, Header:=xlNo
k = Range("T" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h).EntireRow.ClearContents
Range("T:T").ClearContents
End Sub
 
Upvote 0
On top and bottom. Compared to column R some of the top O and bottom O cells are often empty.
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Compressing large amount of rows but adding totals?
Replies
6
Views
119
jkpieterse
jkpieterse
J
  • Question Question
Manual calculation of the median from a series of grades
2
Replies
14
Views
273
felixstraube
F
T
  • Solved
Can I sort a table by applying columns in a different order to the sort request?
Replies
5
Views
191
TheRedCardinal
T
J
  • Question Question
CountIFS and Sumif based on duplicate value in other columns
Replies
3
Views
295
jennybell
J
S
  • Question Question
SUMIFS while ignoring duplicate rows based on values from a column
Replies
4
Views
275
slam
S

Forum statistics

Threads
1,223,911
Messages
6,175,337
Members
452,637
Latest member
Ezio2866

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top