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
 

Some videos you may like

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.

theBardd

Rules violation
Joined
Jan 21, 2012
Messages
912
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
 

ryuryuryu

New Member
Joined
Oct 25, 2008
Messages
26
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
 

theBardd

Rules violation
Joined
Jan 21, 2012
Messages
912
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:

theBardd

Rules violation
Joined
Jan 21, 2012
Messages
912
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
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
39,073
Office Version
365
Platform
Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,096,324
Messages
5,449,720
Members
405,575
Latest member
Masimo85

This Week's Hot Topics

Top