Sub Заточка()
    Dim i&, j&, k&, n&, rm As Range, rd As Range, dc, vm(), vd(), t#
    Set rm = [G3:I11]: Set rd = [G12:I20]
    Application.ScreenUpdating = 0
t = Timer
return_:
    Set dc = CreateObject("Scripting.dictionary")
    [G3:I20].ClearContents
    With dc
        vm = rm.Value: vd = rd.Value
        Randomize

        For j = 1 To 3    ' по колонкам
            For i = 1 To 9    'по строкам мальчики
                If n = 3 Then Exit For    'только 3 мальчика
return1:
                k = Int(Rnd() * 9 + 1)
                If Not .exists(k) Then vm(k, j) = 1: .Item(k) = 1: n = n + 1 Else GoTo return1
            Next
            rm.Value = vm
            k = 0: n = 0
        Next
    End With

    Set dc = CreateObject("Scripting.dictionary")
    With dc
        For j = 1 To 3
            For i = 1 To 9
                If n = 3 Then Exit For    'только 3 девочки
return2:
                k = Int(Rnd() * 9 + 1)
                If Not .exists(k) Then vd(k, j) = 1: .Item(k) = 1: n = n + 1 Else GoTo return2
            Next
            rd.Value = vd
            k = 0: n = 0
        Next
    End With
    If Timer - t > 60 Then MsgBox "Повторим?": Set dc = Nothing: Exit Sub
    If [J25] > 0.5 Or [J26] > 0.5 Then GoTo return_
    Set dc = Nothing
End Sub