Sub randoms1()
Dim i&, i_n&, j&, j_n&
Dim min&, max&, r&, r1&, max1&, min1&
Dim numb() As Long
Dim sum() As Long
Dim tabl() As Long
min = 0
max = 1
i_n = Cells(Rows.Count, 1).End(xlUp).Row
j_n = 15
ReDim numb(i_n - 2)
ReDim sum(i_n - 2)
ReDim tabl(i_n - 2, j_n - 3)
For i = 3 To i_n
   numb(i - 2) = Cells(i, 1)
   If min * (j_n - 3) > numb(i - 2) Then
      min1 = numb(i - 2) \ (j_n - 3)
   Else
      min1 = min
   End If
   
   If max * (j_n - 3) < numb(i - 2) Then
      max1 = numb(i - 2) \ (j_n - 3)
   Else
      max1 = max
   End If
   For j = 4 To j_n
      r = Int((max1 - min1 + 1) * Rnd + min)
      sum(i - 2) = sum(i - 2) + r
      tabl(i - 2, j - 3) = r
   Next j
   Do
      r1 = Int((12) * Rnd + 1)
      If sum(i - 2) > numb(i - 2) And tabl(i - 2, r1) > min1 Then
         tabl(i - 2, r1) = tabl(i - 2, r1) - 1
         sum(i - 2) = sum(i - 2) - 1

      ElseIf sum(i - 2) < numb(i - 2) And tabl(i - 2, r1) <= max1 Then
         tabl(i - 2, r1) = tabl(i - 2, r1) + 1
         sum(i - 2) = sum(i - 2) + 1
      End If
      DoEvents
   Loop While sum(i - 2) <> numb(i - 2)
Next i
For i = 1 To i_n - 2
  For j = 1 To j_n - 3
    Cells(i + 2, j + 3) = tabl(i, j)
  Next j
Next i
End Sub