Randomly Distribution of items across a range with vba

kelly mort

Well-known Member
Joined
Apr 10, 2017
Messages
2,169
Office Version
  1. 2016
Platform
  1. Windows
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
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
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? :confused:
 
Upvote 0
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.

Code:
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
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,184
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top