Distribute randomly to a matrix

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?

user_447970 · Answer

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).

user_4361999 · Answer

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).

Distribute randomly to a matrix

2 Answers