Sort duplicates in the column

[topi1]

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.

 

[topi1]

Could you post an example along with the result?

Unable I think from work. The before file I desired files I added are good examples. In the column R if you add 14,16,17 after 14, it will be good representation. With longer column R and column O filled in the middle.

 

[Akuini]

Compared to column R some of the top O and bottom O cells are often empty.

Can we use col R to determine the last row with data?

 

[Akuini]

Another question :
Is it always the case that if there are blank rows in column O, the first row in column O will also be blank?

 

[topi1]

Another question :
Is it always the case that if there are blank rows in column O, the first row in column O will also be blank?

In fact, first two rows in the column O will always be blank. First row for sure.

 

[Akuini]

Ok, I'll try to amend the code tomorrow when I have time.

 

[topi1]

Ok, I'll try to amend the code tomorrow when I have time.

Thank you so much.

 

[Akuini]

Wait, did you try the last code in post #28. See if it does the job.

 

[Akuini]

Ah, sorry, we should use col R to determine the last row with data, so try this one:

Sub topi1_6()
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
n = Range("R" & Rows.Count).End(xlUp).Row
va = Range("O1:O" & n)
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

 

[topi1]

Ah, sorry, we should use col R to determine the last row with data, so try this one:

Sub topi1_6()
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
n = Range("R" & Rows.Count).End(xlUp).Row
va = Range("O1:O" & n)
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

@Akuini Thank you. 1 stayed but as you can see below, 15,16,17 got moved instead of staying where they were.

Book2
	O	P	Q	R
1				1
2				2
3				3
4	B			4
5	A			5
6	X			6
7	A			7
8	A			8
9	B			9
10	C			10
11	D			11
12	A			12
13	D			13
14	B			14
15				15
16				16
17				17
Sheet2

Book2
	O	P	Q	R
27				1
28				2
29				3
30				15
31				16
32				17
33	B			9
34	B			14
35	A			7
36	A			8
37	A			12
38	X			6
39	C			10
40	D			13
Sheet2

 

[Akuini]

Try this one:

Sub topi1_7()
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
n = Range("R" & Rows.Count).End(xlUp).Row
va = Range("O1:O" & n)
ReDim vb(1 To UBound(va, 1), 1 To 1)
n = 0
For i = 1 To UBound(va, 1)
    If va(i, 1) = "" Then
        n = n + 1
        vb(i, 1) = n
    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