macro or other ways to arrange columns so that there will be no consecutive duplicates

R

ryuryuryu

New Member
Joined
Oct 25, 2008
Messages
26
Hi Everyone,

I have a table of two columns, one column for dates and the other column with duplicates items.

I was wondering if there is a macro to arrange the 1st column by dates, and the second column with no consecutive duplicates (i.e. as much as possible as sometimes there is no way to avoid consecutive duplicates).

I am sure this can be done but I just can't figure it out.

Below is a "before and after" tables showing what I am trying to achieve, in case I wasn't clear about it. Thanks for helping out.

[TABLE="width: 474"]
<tbody>[TR]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
[TABLE="class: grid, width: 500, align: center"]
<tbody>[TR]
[TD]Before[/TD]
[TD][/TD]
[TD][/TD]
[TD]After[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]1 jan 2019[/TD]
[TD]a[/TD]
[TD][/TD]
[TD]1 jan 2019[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]1 jan 2019[/TD]
[TD]a[/TD]
[TD][/TD]
[TD]1 jan 2019[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD]1 jan 2019[/TD]
[TD]b[/TD]
[TD][/TD]
[TD]1 jan 2019[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]1 jan 2019[/TD]
[TD]b[/TD]
[TD][/TD]
[TD]1 jan 2019[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD]1 jan 2019[/TD]
[TD]b[/TD]
[TD][/TD]
[TD]1 jan 2019[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD]2 jan 2019[/TD]
[TD]d[/TD]
[TD][/TD]
[TD]2 jan 2019[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD]2 jan 2019[/TD]
[TD]d[/TD]
[TD][/TD]
[TD]2 jan 2019[/TD]
[TD]e[/TD]
[/TR]
[TR]
[TD]2 jan 2019[/TD]
[TD]e[/TD]
[TD][/TD]
[TD]2 jan 2019[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD]3 jan 2019[/TD]
[TD]f[/TD]
[TD][/TD]
[TD]3 jan 2019[/TD]
[TD]f[/TD]
[/TR]
[TR]
[TD]3 jan 2019[/TD]
[TD]f[/TD]
[TD][/TD]
[TD]3 jan 2019[/TD]
[TD]g[/TD]
[/TR]
[TR]
[TD]3 jan 2019[/TD]
[TD]g[/TD]
[TD][/TD]
[TD]3 jan 2019[/TD]
[TD]f[/TD]
[/TR]
[TR]
[TD]3 jan 2019[/TD]
[TD]g[/TD]
[TD][/TD]
[TD]3 jan 2019[/TD]
[TD]g[/TD]
[/TR]
[TR]
[TD]3 jan 2019[/TD]
[TD]g[/TD]
[TD][/TD]
[TD]3 jan 2019[/TD]
[TD]h[/TD]
[/TR]
[TR]
[TD]3 jan 2019[/TD]
[TD]h[/TD]
[TD][/TD]
[TD]3 jan 2019[/TD]
[TD]g[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]m[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]l[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]m[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]l[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]l[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[/TR]
[TR]
[TD]4 jan 2019[/TD]
[TD]l[/TD]
[TD][/TD]
[TD]4 jan 2019[/TD]
[TD]k[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


cheers,
ryuryuryu
 

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Try this

Code: 
Public Sub RemoveDups()
Dim lastrow As Long
    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("A2").Resize(lastrow - 1), _
                              SortOn:=xlSortOnValues, _
                              Order:=xlAscending, _
                              DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=Range("B2").Resize(lastrow - 1), _
                              SortOn:=xlSortOnValues, _
                              Order:=xlAscending, _
                              DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1:B1").Resize(lastrow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        .Range("A1:B$1").Resize(lastrow).RemoveDuplicates Columns:=Array(1, 2), _
                                                          Header:=xlYes
    End With
End Sub
 
Upvote 0
theBardd said:
Try this

Code: 
Public Sub RemoveDups()
Dim lastrow As Long
    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=Range("A2").Resize(lastrow - 1), _
                              SortOn:=xlSortOnValues, _
                              Order:=xlAscending, _
                              DataOption:=xlSortNormal
        .Sort.SortFields.Add2 Key:=Range("B2").Resize(lastrow - 1), _
                              SortOn:=xlSortOnValues, _
                              Order:=xlAscending, _
                              DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1:B1").Resize(lastrow)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
        .Range("A1:B$1").Resize(lastrow).RemoveDuplicates Columns:=Array(1, 2), _
                                                          Header:=xlYes
    End With
End Sub
Click to expand...


Hi theBardd,

I tried to run the code and got the following error message:

"vba runtime error 438: Object doesn't support this property or method"

When I pressed the debug button, the following code are highlighted:

.Sort.SortFields.Add2 Key:=Range("A2").Resize(lastrow - 1), _ SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal

I am running the code in Excel 2016. I am not sure if that's the reason why it didn't work.

Also, though I cannot run the code to test it, I noticed that RemoveDuplicates was used. I am trying to rearrange the rows so that there is no consecutive duplicates in the column with Column header "Item". The total number of rows of the table should be the same after the macro is run as I am not trying to delete the duplicates. Thanks.

Before the macro is run:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Date[/TD]
[TD]Item[/TD]
[/TR]
[TR]
[TD]1 Jan 2019[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]1 Jan 2019[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]1 Jan 2019[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]e[/TD]
[/TR]
</tbody>[/TABLE]



After the macro is run:
[TABLE="width: 500"]
<tbody>[TR]
[TD]Date[/TD]
[TD]Item[/TD]
[/TR]
[TR]
[TD]1 Jan 2019[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]1 Jan 2019[/TD]
[TD]b[/TD]
[/TR]
[TR]
[TD]1 Jan 2019[/TD]
[TD]a[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]d[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]c[/TD]
[/TR]
[TR]
[TD]2 Jan 2019[/TD]
[TD]e[/TD]
[/TR]
</tbody>[/TABLE]


cheers,
ryuryuryu
 
Upvote 0
I'm using Excel 16 so iut should work, but see if this works better for you

Code: 
Public Sub RemoveDups()
Dim lastrow As Long
    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        .Range("A1:B1").Resize(lastrow).Sort Key1:=Range("A2"), _
                                             Order1:=xlAscending, _
                                             Header:=xlYes
        
        .Range("A1:B$1").Resize(lastrow).RemoveDuplicates Columns:=Array(1, 2), _
                                                          Header:=xlYes
    End With
End Sub
 
Last edited:
Upvote 0
Okay, I've read it properly now and see what you are trying to do.

Take a shot with this (although it doesn't quite work with your first set)

Code: 
Public Sub ReorderDups()
Dim ordered As Boolean
Dim lastrow As Long
Dim i As Long
    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        
        Do
        
        ordered = True
        
            For i = 2 To lastrow
        
                If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
                    .Cells(i, "B").Value = .Cells(i - 1, "B").Value Then
                    
                    .Cells(i, "A").Resize(, 2).Cut
                    .Cells(i + 2, "A").Resize(, 2).Insert Shift:=xlDown
        
                    ordered = False
                End If
            Next i
        Loop Until ordered
    End With
End Sub
 
Upvote 0
Best I could come up with

In C1 & fill down
=MOD(ROW(A1),SUM(COUNTIFS($A$1:$A$21,A1,$B$1:$B$21,$B$1:$B$21)))
Then sort on column A & column C
 
Upvote 0
You must log in or register to reply here.

Similar threads

T
  • Question Question
VBA code to autofill based on a date?
Replies
3
Views
158
Joe4
Joe4
SanjayGMusafir
  • Solved
Text function not returning correct month
Replies
7
Views
160
Alex Blakenburg
A
R
  • Question Question
Leave Database Time Tracking to equal full day after 8 hours
Replies
6
Views
299
NoSparks
N
Y
  • Question Question
Excel Formula --> Return column heading dependent on data in rows (& conditions)
Replies
1
Views
441
Herakles
H
Y
  • Solved
Macro errors out when run automatically, but no problem when step-by-step
Replies
3
Views
316
Alex Blakenburg
A

Forum statistics

Threads
1,223,903
Messages
6,175,284
Members
452,630
Latest member
OdubiYouth

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