Assuming I was correct in my last post:
Private Sub CommandButton1_Click()
Dim RetVal As Variant
Dim FullRange As Range
Dim EntriesCount As Long
Dim BinaryArray() As Long
On Error Resume Next
Set RetVal = Application.InputBox("Enter or select the range to fill.", , ,
, , , , 8)
If RetVal Is Nothing Then Exit Sub
Set FullRange = RetVal
RetVal = Application.InputBox("How many entries in total.", , , , , , , 2)
'2 ?
If RetVal = False Then Exit Sub
If RetVal > FullRange.Cells.Count Then
MsgBox "Not enough cells in the selected range for " & RetVal & "
entries.", vbExclamation + vbOKOnly
Exit Sub
End If
EntriesCount = RetVal
GenerateRandomArray EntriesCount, BinaryArray()
DistributeBinaryValues FullRange, BinaryArray()
End Sub
Private Function GenerateRandomArray(ElementCount As Long, ByRef
ArrayToFill() As Long)
Dim i As Long
ReDim ArrayToFill(ElementCount - 1)
Randomize
For i = 0 To ElementCount - 1
If Rnd() > 0.5 Then
ArrayToFill(i) = 1
Else
ArrayToFill(i) = 0
End If
Next
End Function
Private Function DistributeBinaryValues(ByRef argFullRange As Range,
BinaryValues() As Long)
Dim PlacedCount As Long
Dim RandRow As Long
Dim RandCol As Long
Dim MaxRow As Long
Dim MaxCol As Long
argFullRange.ClearContents
MaxRow = argFullRange.Rows.Count
MaxCol = argFullRange.Columns.Count
Do Until PlacedCount = UBound(BinaryValues) + 1
RandRow = CLng(Rnd * (MaxRow - 1) + 1)
'CLng(Rnd * (high - low)) + low
RandCol = CLng(Rnd * (MaxCol - 1) + 1)
With Cells(RandRow, RandCol)
Debug.Print .Address
If Cells(RandRow, RandCol).Value = "" Then
.Value = BinaryValues(PlacedCount)
PlacedCount = PlacedCount + 1
End If
End With
Loop
End Function
NickHK
