Array Randomly Sorted

[Guest]

I need to create a sub procedure to do this:
(1) load a range (i.e. B2:G2) of numbers from a sheet into an array.
(2) randomly sort this array
(3) paste this resorted array back to the original location.
The range has blanks which are to be randomly sorted just like the numbers.

I would really appreciate your help!
Thank You

 

[JE McGimpsey]

One way, generalized for any two-dimensional array:

Public Sub RandomizeRange(Optional ByVal sRangeAddr = vbNullString)
Dim vArr As Variant
Dim vTemp As Variant
Dim rSort As Range
Dim i As Long, i1 As Long
Dim j As Long, j1 As Long
If sRangeAddr = vbNullString Then
If TypeOf Selection Is Range Then _
Set rSort = Selection
Else
Set rSort = Range(sRangeAddr)
End If
If Not rSort Is Nothing Then
With rSort
vArr = .Value
For i = UBound(vArr, 1) To LBound(vArr, 1) Step -1
For j = UBound(vArr, 2) To LBound(vArr, 2) Step -1
i1 = Int(Rnd() * i) + 1
j1 = Int(Rnd() * j) + 1
vTemp = vArr(i, j)
vArr(i, j) = vArr(i1, j1)
vArr(i1, j1) = vTemp
Next j
Next i
.Value = vArr
End With
End If
End Sub

Call with

RandomizeRange "B2:G2"

 

[Guest]

Sub RanArray()

Dim MyArray() As Variant

MaxCells = ActiveCell.CurrentRegion.Count
ReDim MyArray(MaxCells)


arraycount = 0
For Each cell In ActiveCell.CurrentRegion

MyArray(arraycount) = cell
arraycount = arraycount + 1

Next cell

'adjust for count starting at zero
MaxCells = MaxCells
For Each cell In ActiveCell.CurrentRegion

Index = Int(Rnd(1) * MaxCells)
cell.Value = MyArray(Index)

'compact array
For i = Index To (MaxCells - 1)
MyArray(i) = MyArray(i + 1)
Next i

MaxCells = MaxCells - 1

Next cell

End Sub

 

[Guest]

Very nice Joel

 

[Guest]

Thanks so much !

One way, generalized for any two-dimensional array:

Public Sub RandomizeRange(Optional ByVal sRangeAddr = vbNullString)
Dim vArr As Variant
Dim vTemp As Variant
Dim rSort As Range
Dim i As Long, i1 As Long
Dim j As Long, j1 As Long
If sRangeAddr = vbNullString Then
If TypeOf Selection Is Range Then _
Set rSort = Selection
Else
Set rSort = Range(sRangeAddr)
End If
If Not rSort Is Nothing Then
With rSort
vArr = .Value
For i = UBound(vArr, 1) To LBound(vArr, 1) Step -1
For j = UBound(vArr, 2) To LBound(vArr, 2) Step -1
i1 = Int(Rnd() * i) + 1
j1 = Int(Rnd() * j) + 1
vTemp = vArr(i, j)
vArr(i, j) = vArr(i1, j1)
vArr(i1, j1) = vTemp
Next j
Next i
.Value = vArr
End With
End If
End Sub

Call with

RandomizeRange "B2:G2"