Random generated value inside grid.

[Afro_Cookie]

I have a 10x10 grid from A1:J10 and want to generate a 'x' in the cells in a random order, based off the below criteria, almost like a reverse COUNTA() function.
- Each row and each column has 4 'x' in it.
- The placement of those 'x' are random.

Something similar to the below grid, but with the placements randomized?

	1	2	3	4	5	6	7	8	9	10	Total
1	x	x	x	x							4
2		x	x	x	x						4
3			x	x	x	x					4
4				x	x	x	x				4
5					x	x	x	x			4
6						x	x	x	x		4
7							x	x	x	x	4
8	x							x	x	x	4
9	x	x							x	x	4
10	x	x	x							x	4
Total	4	4	4	4	4	4	4	4	4	4

 

[johnnyL]

This question caused me a few more grey hairs, but I think the following code will do what you asked for:

Sub RandomlyPlaceXs()
'
    Dim i                       As Long, j                      As Long, temp   As Long
    Dim RowCount                As Long
    Dim ColumnNumbersArray()    As Variant
    Dim Column_X_CountArray()   As Long, Row_X_CountArray()     As Long
'
    With Range("A1:J10")
        .ClearContents
'
        ReDim ColumnNumbersArray(1 To .Columns.Count)
        For i = 1 To .Columns.Count
            ColumnNumbersArray(i) = i
        Next
'
        ReDim Column_X_CountArray(1 To .Columns.Count)
        ReDim Row_X_CountArray(1 To .Rows.Count)
'
' Randomly place four 'X' values in each row while ensuring each column has exactly four 'X' values
        For RowCount = 1 To .Rows.Count
' Shuffle the ColumnNumbersArray using Fisher-Yates algorithm
            For i = LBound(ColumnNumbersArray) To UBound(ColumnNumbersArray) - 1
                j = WorksheetFunction.RandBetween(i, UBound(ColumnNumbersArray))
                temp = ColumnNumbersArray(j)
                ColumnNumbersArray(j) = ColumnNumbersArray(i)
                ColumnNumbersArray(i) = temp
            Next
'
' Fill each row with exactly 4 X's
            For i = 1 To UBound(ColumnNumbersArray)
                If Row_X_CountArray(RowCount) > 3 Then Exit For
'
                If .Cells(RowCount, ColumnNumbersArray(i)).Value2 = "" And _
                        Column_X_CountArray(ColumnNumbersArray(i)) < 4 Then
                    .Cells(RowCount, ColumnNumbersArray(i)).Value2 = "X"
                    Column_X_CountArray(ColumnNumbersArray(i)) = Column_X_CountArray(ColumnNumbersArray(i)) + 1
                    Row_X_CountArray(RowCount) = Row_X_CountArray(RowCount) + 1
                End If
            Next
        Next
    End With
'
' Check if the last row of Row_X_CountArray has exactly 4 'X's and recursively call the subroutine if not
    If Row_X_CountArray(RowCount - 1) <> 4 Then Call RandomlyPlaceXs
End Sub

 

[Afro_Cookie]

This question caused me a few more grey hairs, but I think the following code will do what you asked for:

Sub RandomlyPlaceXs()
'
    Dim i                       As Long, j                      As Long, temp   As Long
    Dim RowCount                As Long
    Dim ColumnNumbersArray()    As Variant
    Dim Column_X_CountArray()   As Long, Row_X_CountArray()     As Long
'
    With Range("A1:J10")
        .ClearContents
'
        ReDim ColumnNumbersArray(1 To .Columns.Count)
        For i = 1 To .Columns.Count
            ColumnNumbersArray(i) = i
        Next
'
        ReDim Column_X_CountArray(1 To .Columns.Count)
        ReDim Row_X_CountArray(1 To .Rows.Count)
'
' Randomly place four 'X' values in each row while ensuring each column has exactly four 'X' values
        For RowCount = 1 To .Rows.Count
' Shuffle the ColumnNumbersArray using Fisher-Yates algorithm
            For i = LBound(ColumnNumbersArray) To UBound(ColumnNumbersArray) - 1
                j = WorksheetFunction.RandBetween(i, UBound(ColumnNumbersArray))
                temp = ColumnNumbersArray(j)
                ColumnNumbersArray(j) = ColumnNumbersArray(i)
                ColumnNumbersArray(i) = temp
            Next
'
' Fill each row with exactly 4 X's
            For i = 1 To UBound(ColumnNumbersArray)
                If Row_X_CountArray(RowCount) > 3 Then Exit For
'
                If .Cells(RowCount, ColumnNumbersArray(i)).Value2 = "" And _
                        Column_X_CountArray(ColumnNumbersArray(i)) < 4 Then
                    .Cells(RowCount, ColumnNumbersArray(i)).Value2 = "X"
                    Column_X_CountArray(ColumnNumbersArray(i)) = Column_X_CountArray(ColumnNumbersArray(i)) + 1
                    Row_X_CountArray(RowCount) = Row_X_CountArray(RowCount) + 1
                End If
            Next
        Next
    End With
'
' Check if the last row of Row_X_CountArray has exactly 4 'X's and recursively call the subroutine if not
    If Row_X_CountArray(RowCount - 1) <> 4 Then Call RandomlyPlaceXs
End Sub

The hairs were well worth it. This works perfectly.

 

[johnnyL]

Glad to help.