Selected Answer
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
.Clear
.Add Key:=Rng.Cells(1), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
End With
.SetRange Rng
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
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)
Loop
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.