Private Function Comb(r As Long, n As Long)
  Dim c1 As New Collection, c2 As New Collection, arr(), arrTemp(), i As Long, j As Long, v
  For i = 1 To n
    c1.Add Array(-1, i)
  Next i
  While c1.Count
    arr = c1(1)
    c1.Remove 1
    j = UBound(arr)
    If j = r Then
      c2.Add arr
    Else
      ReDim Preserve arr(j + 1)
      For i = arr(j) + 1 To n
        arr(j + 1) = i
        c1.Add arr
      Next i
    End If
  Wend
  ReDim arr(1 To c2.Count)
  ReDim arrTemp(1 To r)
  i = 0
  For Each v In c2
    i = i + 1
    For j = 1 To r
      arrTemp(j) = v(j)
    Next j
    arr(i) = arrTemp
  Next v
  Comb = arr
End Function

Sub Main()
  Dim rng As Range, arrTemp(), arr(), arr1(), arr2(), arrComb(1 To 4), isFound As Boolean, v
  Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i As Long, j As Long, k As Long

  For i = 1 To 4
    arrComb(i) = Comb(i, 5)
  Next i

  Sheets("Plan2").Select
  Set rng = Range("A1").CurrentRegion
  Rows("12:23").ClearContents
  rng.Interior.ColorIndex = 2
  arr = rng.Value
  ReDim arrTemp(1 To 5)

loop1:
  arr1 = arr
  For i = 1 To 5
    arrTemp(1) = 1: arrTemp(2) = 1: arrTemp(3) = Int(Rnd * 2): arrTemp(4) = 0: arrTemp(5) = 0
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    If k = 0 Or k = 5 Then GoTo loop1
  Next j
  arr = arr1

loop2:
  arr1 = arr
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i, j))
    Next j
    For j = 1 To k
      arrTemp(j) = 0
    Next j
    For j = k + 1 To 5
      arrTemp(j) = 1
    Next j
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j + 5) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j + 5))
    Next i
    If k = 0 Or k = 5 Then GoTo loop2
  Next j
  arr = arr1
  
loop3:
  arr1 = arr
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    For i = 1 To k
      arrTemp(i) = 0
    Next i
    For i = k + 1 To 5
      arrTemp(i) = 1
    Next i
    For i = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(i)
      arrTemp(i) = arrTemp(k)
      arrTemp(k) = v
    Next i
    For i = 1 To 5
      arr1(i + 5, j) = IIf(arrTemp(i) = 1, 1, vbNullString)
    Next i
  Next j
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    If k = 0 Or k = 5 Then GoTo loop3
  Next i
  arr = arr1
  
loop4:
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    arrTemp(i) = arrComb(5 - k)
  Next i
  For i1 = 1 To UBound(arrTemp(1))
    For j = 1 To 5
      arr1(6, j + 5) = vbNullString
    Next j
    For j = 1 To UBound(arrTemp(1)(i1))
      arr1(6, 5 + arrTemp(1)(i1)(j)) = 1
    Next j
    For i2 = 1 To UBound(arrTemp(2))
      For j = 1 To 5
        arr1(7, j + 5) = vbNullString
      Next j
      For j = 1 To UBound(arrTemp(2)(i2))
        arr1(7, 5 + arrTemp(2)(i2)(j)) = 1
      Next j
      For i3 = 1 To UBound(arrTemp(3))
        For j = 1 To 5
          arr1(8, j + 5) = vbNullString
        Next j
        For j = 1 To UBound(arrTemp(3)(i3))
          arr1(8, 5 + arrTemp(3)(i3)(j)) = 1
        Next j
        For i4 = 1 To UBound(arrTemp(4))
          For j = 1 To 5
            arr1(9, j + 5) = vbNullString
          Next j
          For j = 1 To UBound(arrTemp(4)(i4))
            arr1(9, 5 + arrTemp(4)(i4)(j)) = 1
          Next j
          For i5 = 1 To UBound(arrTemp(5))
            For j = 1 To 5
              arr1(10, j + 5) = vbNullString
            Next j
            For j = 1 To UBound(arrTemp(5)(i5))
              arr1(10, 5 + arrTemp(5)(i5)(j)) = 1
            Next j
           '=================
            isFound = True
             For j = 1 To 5
               k = 0
              For i = 1 To 10
                k = k + Val(arr1(i, j + 5))
              Next i
              If k <> 5 Then
                 isFound = False
                 Exit For
              End If
            Next j
            If isFound Then
               arr = rng.Value
               For i = 1 To UBound(arr, 1)
                 For j = 1 To UBound(arr, 2)
                   If arr1(i, j) = vbNullString Then arr(i, j) = vbNullString
                 Next j
               Next i
               Range("A12").Resize(UBound(arr1, 1), UBound(arr, 2)).Value = arr
               ReDim arrTemp(1 To 1, 1 To 101)
               k = 0
               For i = 1 To 5
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 1 To 5
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               k = k + 1
               arrTemp(1, k) = "Total " & k - 1 & " numbers."
               Range("A23").Resize(1, k) = arrTemp
               Exit Sub
            End If
           '=================
          Next i5
        Next i4
      Next i3
    Next i2
  Next i1
End Sub
Sub Generate300()
  Dim i As Long
  With Sheets("Plan3")
    .Cells.ClearContents
    For i = 1 To 300
      Main
      Sheets("Plan2").Range("A23").CurrentRegion.Copy .Range("A65000").End(xlUp).Offset(1)
      MsgBox "Iteration : " & i
    Next i
  End With
End Sub