Evenly spread duplicate data in list


Hi, I have a long list of numbers in one column, and it includes alot of duplicates. I want to randomly shuffle this list so that all duplicates within the list are all evenly distributed.

As far as I have come by myself...

I have tried to use a VBA called "ShuffleArrayInPlace" from h**p://www.cpearson.com/excel/ShuffleArray.aspx however the result is a list where some of the numbers are very close to each other. 

Is there a way to have all duplicate numbers in this kind of shuffled list evenly spread across the list?




Tricky job. I worked it out in the third attempt :-)
Please put your numbers in column C. You can adjust that in the code as well as the first row containing a number. Take note of the comments in the code. Paste the code in a standard code module (by default "Module1"). Run the main sub "DistributeDuplicates". The other procedures are for its use only.

Option Explicit
Sub DistributeDuplicates()
    ' 03 Oct 2017
    Dim Rng As Range                        ' worksheet range holding numbers
    Dim n As Long                           ' numbers count
    Dim Arr As Variant                      ' = Rng.Value
    Dim Srt() As Variant                    ' sorting array
    Dim C As Long                           ' helper column
    Dim Dmax As Integer                     ' maximum number of duplicates
    Dim R As Long
    Dim i As Long
    Application.ScreenUpdating = False
    With ActiveSheet
        ' numbers are in column C, starting from row 2
        R = .Cells(.Rows.Count, "C").End(xlUp).Row
        Set Rng = .Range(.Cells(2, "C"), .Cells(R, "C"))
        Arr = Rng.Value
        n = UBound(Arr)
        ' =======================================================
        ' Remove the following lines if you want to sort in place
        C = .UsedRange.Columns.Count + 1
        Set Rng = .Cells(1, C).Resize(n, 1)
        Rng.Value = Arr
        ' Remove the above lines if you want to sort in place
        ' =======================================================
        SortRange Rng
        Arr = Rng.Value
    End With
    For R = 1 To UBound(Arr)
        With Application
            Dmax = .Max(Dmax, Application.CountIf(Rng, Arr(R, 1)))
        End With
    Next R
    ReDim Srt(1 To Dmax, 1 To n)
    i = 1
    C = 0
    For R = 1 To n
        C = C + 1
        If C > Dmax Then
            C = 1
            i = i + 1
        End If
        Srt(C, i) = Arr(R, 1)
    Next R
    ReDim Arr(1 To n)
    R = 1
    For C = 1 To Dmax
        For i = 1 To n
            If Srt(C, i) = "" Then Exit For
            Arr(R) = Srt(C, i)
            R = R + 1
        Next i
    Next C
    ' =======================================================
    ' The following code gives the series a random starting point.
    ' Remove the following lines if you want repetitive identical results.
    Srt = Arr
    ReDim Arr(1 To n)
    i = Int(n * Rnd + 1)
    For R = 1 To n
        Arr(R) = Srt(i)
        i = i + 1
        If i > n Then i = 1
    Next R
    ' Note: This code doesn't change the sequence of number,
    '       just the point at which the sequence starts.
    ' =======================================================
    Rng.Value = Application.Transpose(Arr)
    Application.ScreenUpdating = True
End Sub
Private Sub SortRange(Rng As Range)
    ' 03 Oct 2017
    With Rng.Parent.Sort
        With .SortFields
            .Add Key:=Rng.Cells(1), _
                      SortOn:=xlSortOnValues, _
                      Order:=xlAscending, _
        End With
        .SetRange Rng
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
    End With
End Sub
Private Function NextIndex(ByVal i As Long, _
                           ByVal Ival As Integer, _
                           ByVal n As Long, _
                           Arr As Variant) As Long
    ' 03 Oct 2017
    Dim Fun As Long
    Fun = NextBlank(i, Arr)
    Fun = (Fun + Ival) Mod n
    If Fun = 0 Then Fun = n
    NextIndex = NextBlank(Fun, Arr)
End Function
Private Function NextBlank(ByVal i As Long, _
                           Arr As Variant) As Long
    ' 03 Oct 2017
    Do While Arr(i) <> ""
        i = i + 1
        If i > UBound(Arr) Then i = LBound(Arr)
    NextBlank = i
End Function

Other than the adjustment of where you have your original series of numbers you can also determine where you want the shuffled output. If you run the code as it is the output will be in a dedicated column on the right of your existing worksheet content. If you remove the lines of code which create this column the output will over-write the input series.

You can also decide whether you want a different series every time you run the code or the same one. Remove the indicated lines of code. You can "remove" the lines by prefixing an apostrophe to each line you want not to run. VBA' compiler will consider those lines as remarks and ignore them.


Answer the Question

You must create an account to use the forum. Create an Account or Login