Distribute randomly to a matrix - excel

Question

I have a matrix, let's say 5 columns and 10 rows.
Then I have 30 stars. I want to put them into the matrix so that the number of stars on each row is the same and the number of stars on each column is the same (3 stars each row and 6 stars each column).
If I have 40 stars, there should be 4 stars each row and 8 stars each column.
I can do the matrix by hand and I really did both cases. But the bigger the matrix is, the harder I fill the stars.
I suppose there should be a principle behind it but still haven't figure it out.
I am using VBA in Excel to generate the 5x10 matrix with 30 stars, but it takes some minutes to try all possibilities with a loop.
Sub test()
Dim xRange As Range
Set xRange = Selection
GoTo FillX
GoTo CheckRows
FillX:
xRange.Clear
xRange.HorizontalAlignment = xlCenter
For i1 = 1 To 5
For i2 = 1 To 6
v = Int(Rnd() * 10 + 1)
While xRange.Cells(v, i1).Value = "x"
v = Int(Rnd() * 10 + 1)
Wend
xRange.Cells(v, i1).Value = "x"
Next
Next
CheckRows:
x = 0
For Each Row In xRange.Rows
If WorksheetFunction.CountA(Row) <> 3 Then
x = x + 1
End If
Next
While x <> 0
GoTo FillX
GoTo CheckRows
Wend
End Sub
Is there a solution which can randomly distribute stars to a range of any size?

Answer 1

Goto should be avoided. Use loops instead.
This code first calculates the number of stars for each row, then uses nested loops to enter them, so there are never more stars in a row. By stepping to the next row, but retaining the column position, and then starting in the same row in the first column, you can ensure that there are no more than the defined number of stars in a column, either. The blank cells will travel diagonally from top left to right. You can see this when you apply conditional formatting.
With this pattern, you don't need to use trial and error and the code runs super fast.
Sub test()
Dim gridRows As Long, gridColumns As Long, Stars As Long
Dim myRow As Long, myColumn As Long
Dim i As Long, j As Long
Dim rowCounter As Long, columnCounter As Long, rowOffset As Long
Dim ws As Worksheet
Set ws = Me
'You can get the grid rows and columns and the number of stars from
' user input or from worksheet cells in you want. Just make sure
' they end up in the variables below.
gridRows = 20
gridColumns = 10
Stars = 60
mycolumns = Stars / gridRows
myRows = Stars / gridColumns
j = 1
rowCounter = 1
columnCounter = 1
ws.Range("A1:zz9990").ClearContents
For j = 1 To gridRows
rowOffset = 0
For i = 1 To gridColumns
ws.Cells(j, i) = 1
columnCounter = columnCounter + 1
If columnCounter > mycolumns Then
j = j + 1
columnCounter = 1
rowOffset = 1
End If
Next i
j = j - rowOffset
Next j
' randomize the results
Dim SortRange As Range
' randomize the columns
Set SortRange = ws.Range(ws.Cells(gridRows + 1, 1), ws.Cells(gridRows + 1, gridColumns))
' enter random numbers
For Each cel In SortRange
Debug.Print cel.Address
cel.Value = Rnd
Next cel
' sort left to right
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=SortRange _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange Range("A1", Cells(gridRows + 1, gridColumns))
.Header = xlGuess
.Orientation = xlLeftToRight
.SortMethod = xlPinYin
.Apply
End With
' clear the random numbers
SortRange.ClearContents
Set SortRange = ws.Range(ws.Cells(1, gridColumns + 1), ws.Cells(gridRows, gridColumns + 1))
' randomize the rows
' enter random numbers
For Each cel In SortRange
Debug.Print cel.Address
cel.Value = Rnd
Next cel
'Sort Rows
ws.Sort.SortFields.Clear
ws.Sort.SortFields.Add2 Key:=SortRange _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ws.Sort
.SetRange Range("A1", Cells(gridRows, gridColumns + 1))
.Header = xlGuess
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
' clear the random numbers
SortRange.ClearContents
End Sub
Edit after comment: Added code to randomize the results. Add a row with random numbers to the end of the table, sort by those random numbers left to right, and remove them again. Do the same with a column of random numbers and sort top to bottom, then remove the helper numbers.
The screenshot shows a grid with 20 rows, 10 columns and 60 stars using conditional formatting to show the distribution better.
A grid with 60 rows, 30 columns and 1200 stars takes less than a second to build (without using conditional formatting).

Answer 2

This code works a lot quicker (under 1 second mostly).
Sub Button1_Click()
Set xRange = [a1:e10]
x = 0
While x < 6
xRange.Clear
xRange.HorizontalAlignment = xlCenter
For i1 = 1 To 4
For i2 = 1 To 6
Do
g3 = False
Do
v = Int(Rnd * 10 + 1)
Loop While xRange.Cells(v, i1).Value = "x"
xRange.Cells(v, i1).Value = "x"
If WorksheetFunction.CountA(xRange.Rows(v)) > 3 Then
xRange.Cells(v, i1).Value = " "
g3 = True
End If
Loop While g3 = True
xRange.Cells(v, i1).Value = "x"
Next i2
Next i1
x = 0
For Each Row In xRange.Rows
If WorksheetFunction.CountA(Row) = 2 Then x = x + 1
Next Row
Wend
For i2 = 1 To 6
Do
g3 = False
Do
v = Int(Rnd * 10 + 1)
Loop While xRange.Cells(v, 5).Value = "x"
xRange.Cells(v, 5).Value = "x"
If WorksheetFunction.CountA(xRange.Rows(v)) > 3 Then
xRange.Cells(v, i1).Value = " "
g3 = True
End If
Loop While g3 = True
xRange.Cells(v, 5).Value = "x"
Next i2
End Sub
It performs a condition on the rows as well, checking that they have no more than 3 stars in them.
This is done for the first four rows, and then it checks to see if there are at least 6 rows in the last column that can take another star (i.e. have exactly 2 stars already).