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
Sorry, the above code is flawed.
Try this one:
VBA Code: 
Sub topi1_3()
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
k = Range("A" & Rows.Count).End(xlUp).Row
va = Range("A1:A" & k)
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 C as temporary helper column
Range("C1").Resize(UBound(vb, 1), 1) = vb
Range("A:C").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlNo
k = Range("C" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h, 2).ClearContents
Range("C:C").ClearContents
End Sub
 
Upvote 0

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Akuini said:
Sorry, the above code is flawed.
Try this one:
VBA Code: 
Sub topi1_3()
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
k = Range("A" & Rows.Count).End(xlUp).Row
va = Range("A1:A" & k)
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 C as temporary helper column
Range("C1").Resize(UBound(vb, 1), 1) = vb
Range("A:C").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlNo
k = Range("C" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h, 2).ClearContents
Range("C:C").ClearContents
End Sub
Click to expand...
Perfect. Thank you for all your time. And prompt help.
 
Upvote 0
You're welcome, glad to help & thanks for the feedback.:)
 
Upvote 0
See if this works...
Code: 
Sub test()
    Dim a, x, i&, ii&, n&, s$, temp
    With [a1].CurrentRegion
        .Sort .Columns(2)
        a = .Value
        ReDim x(1 To UBound(a, 1))
        For i = 1 To UBound(a, 1)
            If a(i, 2) <> "" Then
                temp = a(i, 1): a(i, 2) = "": s = i
                For ii = i + 1 To UBound(a, 1)
                    If a(ii, 1) = temp Then
                        s = IIf(s Like "*,*", s & ",", ",") & ii
                        a(ii, 2) = ""
                    End If
                Next
                n = n + 1: x(n) = Mid$(s, 1 + IIf(s Like ",*", 1, 0)): s = ""
            End If
        Next
        ReDim Preserve x(1 To n)
        x = Split(Join(x, ","), ",")
        a = Application.Index(.Value, Application.Transpose(x), [{1,2}])
        .ClearContents
        .Resize(UBound(a, 1)) = a
    End With
End Sub
 
Upvote 0
@Akuini I modified your code to adjust to a set of data. Instead of column A, I need column O. Instead of column C as helper column, I need column T. Data is column H to S.

I modified your code but it did not work. Here is the modified code, and a line at then where I wonder I am making a mistake. Please help. 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
k = Range("O" & Rows.Count).End(xlUp).Row
va = Range("O1:O" & k)
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 C as temporary helper column
Range("T1").Resize(UBound(vb, 1), 1) = vb
Range("O:T").Sort Key1:=Range("T1"), Order1:=xlAscending, Header:=xlNo
k = Range("T" & Rows.Count).End(xlUp).Row
Cells(k + 1, 1).Resize(h, 2).ClearContents
Range("T:T").ClearContents
End Sub


Something wrong with the following line??

Code: 
Cells(k + 1, 1).Resize(h, 2).ClearContents
 
Upvote 0
The new data is like this...

Book1 (version 1).xlsb
OPQR
1B1
2A2
3X3
4A4
5A5
6B6
7C7
8D8
9A9
10D10
Sheet3
 
Upvote 0
Fuji said:
See if this works...
Code: 
Sub test()
    Dim a, x, i&, ii&, n&, s$, temp
    With [a1].CurrentRegion
        .Sort .Columns(2)
        a = .Value
        ReDim x(1 To UBound(a, 1))
        For i = 1 To UBound(a, 1)
            If a(i, 2) <> "" Then
                temp = a(i, 1): a(i, 2) = "": s = i
                For ii = i + 1 To UBound(a, 1)
                    If a(ii, 1) = temp Then
                        s = IIf(s Like "*,*", s & ",", ",") & ii
                        a(ii, 2) = ""
                    End If
                Next
                n = n + 1: x(n) = Mid$(s, 1 + IIf(s Like ",*", 1, 0)): s = ""
            End If
        Next
        ReDim Preserve x(1 To n)
        x = Split(Join(x, ","), ",")
        a = Application.Index(.Value, Application.Transpose(x), [{1,2}])
        .ClearContents
        .Resize(UBound(a, 1)) = a
    End With
End Sub
Click to expand...
Thank you @Fuji. Ill check.
 
Upvote 0
topi1 said:
Columns h to s, and certain rows can be blank. It varies.
Click to expand...
1. If columns P and Q are sorted, should the other columns also be sorted? If yes, which columns should be sorted? Columns H to S?
2. If a row in columns P and Q are deleted, should the entire row get deleted?
 
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,912
Messages
6,175,341
Members
452,638
Latest member
Oluwabukunmi

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