Randomly Distribution of items across a range with vba

[kelly mort]

I have this table of the range

B2:J6

And I am looking for a way to randomly distribute the letters A-I across.

These are the rules:
1. A row can take just A or A and A . If 2 As, then they should be immediately adjacent each other. Example B2C2.

2. The first four letters can appear more than the last five.

3. Columns E and H are excluded.

I hope this is achievable.

Thanks in advance

 

[DanteAmor]

It's like a labyrinth, it reaches a dead end.

 

[kelly mort]

It's like a labyrinth, it reaches a dead end.

Hahaha. Noticed that.

So can you revert it to the one with no rule of placing the first four more than the rest?

So that we can avoid that dead end?

But in all, I really admire your intelligence.

How scary is it to be such skillful?

 

[DanteAmor]

Thanks for your kind words.


I'm going to leave the rules, and I'm going to repeat the whole frame up to 7 times to find the required data.

Option Explicit
Sub Randomly()
    Dim r As Range, c As Range
    Dim ale As Long, cnt As Long, n As Long, counter As Long, countB As Long
    Dim things As Variant, letter As String, exists As Boolean, wRepeat As Boolean
    Dim rws As Variant, j As Long, rep As Long, rep2 As Long
    
    Application.ScreenUpdating = False
    
    things = Array("Apple", "Orange", "Mango", "Lime", "Lemon", "Banana", "Melon", "Pine", "Pear")
    
    rws = Array(2, 5, 8, 11, 14)
    Set r = Range("B2:D16,F2:G16,I2:J16")
    rep2 = 0
    Do While True
        r.ClearContents
        wRepeat = False
        For Each c In r
            exists = True
            n = UBound(things)
            Do While exists
                ale = WorksheetFunction.RandBetween(0, n)
                exists = False
                cnt = WorksheetFunction.CountIf(Range(Cells(c.Row, "B"), Cells(c.Row, "J")), ale)
                If (cnt = 1 And c.Offset(, -1).Value <> ale) Or cnt = 2 Then exists = True
                
                counter = WorksheetFunction.CountIf(Range(Cells(c.Row, "B"), Cells(c.Row, "J")), ">" & 3)
                If counter > 2 And ale > 3 Then
                    exists = True
                    n = 3
                End If
                For j = 0 To UBound(rws)
                    If c.Row >= rws(j) And c.Row <= rws(j) + 2 Then
                        countB = WorksheetFunction.CountIf(Range(Cells(rws(j), c.Column), Cells(rws(j) + 2, c.Column)), ale)
                        If countB > 0 Then
                            exists = True
                        End If
                        Exit For
                    End If
                Next
                rep = rep + 1
                If rep = 50 Then
                    wRepeat = True
                    Exit For
                End If
            Loop
            c.Value = ale
            rep = 0
        Next
        If wRepeat = False Then
            Exit Do
        Else
            rep2 = rep2 + 1
            If rep2 = 7 Then
                MsgBox "The bucle encountered a failure", vbCritical
                Exit Sub
            End If
        End If
    Loop
    For n = 0 To UBound(things)
        r.Replace n, things(n)
    Next
End Sub

 

[kelly mort]

Fantastic! !!!


This latest code is very cute.

I think it's okay for now. I will spend some time to analyze it properly and see what I can do with it.

I am very grateful.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.