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

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.


<tbody>
</tbody>
BeforeAfter
1 jan 2019a1 jan 2019a
1 jan 2019a1 jan 2019b
1 jan 2019b1 jan 2019a
1 jan 2019b1 jan 2019b
1 jan 2019b1 jan 2019b
2 jan 2019d2 jan 2019d
2 jan 2019d2 jan 2019e
2 jan 2019e2 jan 2019d
3 jan 2019f3 jan 2019f
3 jan 2019f3 jan 2019g
3 jan 2019g3 jan 2019f
3 jan 2019g3 jan 2019g
3 jan 2019g3 jan 2019h
3 jan 2019h3 jan 2019g
4 jan 2019k4 jan 2019k
4 jan 2019k4 jan 2019m
4 jan 2019k4 jan 2019l
4 jan 2019k4 jan 2019k
4 jan 2019m4 jan 2019l
4 jan 2019l4 jan 2019k
4 jan 2019l4 jan 2019k

<tbody>
</tbody>


cheers,
ryuryuryu
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
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
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


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:

DateItem
1 Jan 2019a
1 Jan 2019a
1 Jan 2019b
2 Jan 2019c
2 Jan 2019c
2 Jan 2019c
2 Jan 2019d
2 Jan 2019d
2 Jan 2019e

<tbody>
</tbody>



After the macro is run:
DateItem
1 Jan 2019a
1 Jan 2019b
1 Jan 2019a
2 Jan 2019c
2 Jan 2019d
2 Jan 2019c
2 Jan 2019d
2 Jan 2019c
2 Jan 2019e

<tbody>
</tbody>


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

Forum statistics

Threads
1,213,486
Messages
6,113,932
Members
448,533
Latest member
thietbibeboiwasaco

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