Macro to reorder duplicates (with condition that no two can be after the other)

[Faintkitara]

It seems like something that can be done, but I could not find any help on the other websites.

I have a list of dates:

10/27/17
10/27/17
10/27/17
5/3/18
4/2/16
4/2/16


This is just a sample of hundreds of data with other information in their subsequent rows. Is there a macro to where the following dates can be listed where no two eqivalent dates can be listed after each other. So the duplicates can be rearranged to where no two are listed after each other in the same column. Like this:

10/27/17
4/2/16
10/27/17
5/3/18
10/27/17
4/2/16

Any response would be greatly appreciated. Please help me figure out this macro!!

[Kaper]

You may try the following:

Sub rearrange()
Const dates = "C", fromcolumn = "A", numcolumns = 5, fromrow = 1
Dim rearrangements As Long, i As Long, lastrow As Long, movement As Long, counter As Long
Application.ScreenUpdating = False
lastrow = Cells(Rows.Count, dates).End(xlUp).Row
Do
  counter = counter + 1
  rearrangements = 0
  For i = fromrow To lastrow - 1
    If Cells(i, dates).Value = Cells(i + 1, dates).Value Then
      movement = Round((1.5 + Rnd * (lastrow - fromrow) / 3) * IIf((i - fromrow) > (lastrow - fromrow) / 2, -1, 1))
 '     Debug.Print "row: " & i, "moved to: " & i + 1 + movement
      Cells(i, fromcolumn).Resize(1, numcolumns).Cut
      Cells(i + 1 + movement, fromcolumn).Resize(1, numcolumns).Insert shift:=xlDown
      rearrangements = rearrangements + 1
      Application.CutCopyMode = False
    End If
  Next i
' Debug.Print "attempt: " & counter, "swaps done: " & rearrangements
Loop Until rearrangements = 0 Or counter >= Sqr(lastrow - fromrow)
If rearrangements <> 0 Then MsgBox "During last run there was still " & _
  rearrangements & vbCrLf & "to be done", vbInformation, "Very tough dataset!"
End Sub

change the constants at the beginning - column where your dates areL dates = "C"
column where data sits - may be left from column with dates or if dates are leftmost write the same, for instance: fromcolumn = "C"
numcolumns = 5 (so in my example I tested it on data written in A:E). If you have only dates column (no other info associated with date then use 1
and finally: where real information starts - in test file I had no header, so fromrow = 1 was just what was needed.

Enjoy

[Kaper]

PS. I tried it for several cases and the final message is added just for very weird data (like half of the set one date, second half second date).
Otherwise the macro is reasonably effective and quick. Of cousre for complicated workbooks it could be wise to switch Excel to manual recalculation mode before the macro and back to automatic after.
Also for really big datasets transfering all data into array and then swaping array rows would probably improve speed, but you were referring to hundreds, so working within worksheet shall be fine..

[JOHN H. DAVIS]

FWIW:

Sub Faintkitaraz()
Dim x As Long, y As Long, z As Long
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
x = 0
y = ActiveSheet.UsedRange.Columns.Count + 1
z = Range("A" & Rows.Count).End(3).row
Columns(2).Insert
Range("A2").Select
Do Until ActiveCell.Offset(1) = ""
    If ActiveCell.Value = ActiveCell.Offset(1).Value Then
        x = x + 1
        ActiveCell.Offset(, 1).Value = x
            Do Until ActiveCell.Value <> ActiveCell.Offset(1).Value
                    x = x + 1
                ActiveCell.Offset(, 1).Value = x
                ActiveCell.Offset(1).Select
            Loop
            ActiveCell.Offset(, 1).Value = 1
    Else
        ActiveCell.Offset(, 1) = 1
    End If
x = 0
ActiveCell.Offset(1).Select
Loop
Range(Cells(2, 1), Cells(z, y)).Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), Order2:=xlDescending
Columns(2).Delete
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
End Sub

[Kaper]

Hi John,
Unfortunately ... I think it does not work in some simple cases
see attached test file

[Faintkitara]

Thank you, Kaper! It seems to work, but there were two places where duplicates were still together. I'm pretty sure it was something that I did, but this is what I changed in the code:

Const dates = "A", fromcolumn = "A", numcolumns = 4, fromrow = 1

The data with the dates is in column A, there are 4 columns of data that needs to stay with those dates A:D, the first row has the names of those columns. Did I do this correctly? Thanks for the help.


There were still duplicates in John's approach, but I did not change the code to fit my data so that may be why

[Faintkitara]

Nevermind, I figured that if you have an empty gap in the data thats in the end column, the macro wont run there. Thanks for the help!

[JOHN H. DAVIS]

@ Kaper: You're right I only tested it on the 1st sample. I thought it would work for all.