Unique cell fill formula or vba

[palaeontology]

I would like to have a 6x6 range (eg: E3:J8) where some cells are filled black, and some are filled white ... I would, however, like each corner cell to have no choice but to be black.

To produce multiples of these 6x6 ranges on the one A4 page, I could write a basic formula into each cell .... =randbetween(1,2) and conditionally format each cell to fill black if "1", and white if "2".

However, two problems :

1. I would like to produce hundreds of these 6x6 grids but each with a UNIQUE pattern of black and white.
2. Using Randbetween has the issue that the value can change when a worksheet is recalculated after entering a formula or data into a different cell.

Is there a formula or some vba code I could use to create 1000 of the more than 4 billion possible combinations of patterns possible ?

I'd like to have these 1000 grids all visible on the one worksheet.

Is this possible ?

Kind regards,

Chris

 

[Eric W]

You could use formulas, but as you said, they'd recalculate and change your grids. You could set Calculation mode to manual after they calculate the first time, but even so I don't think that's the best plan.

Open a new workbook. Right click on the sheet tab and select View Code. From the VBA Editor menu, select Insert > Module. Copy this code:

Sub MakeGrids()
Dim HowMany As Long, UsedGrids As Object, i As Long, str1 As String, ctr As Long
Dim MyEdges As Variant, StartCell As Range, r As Long, c As Long, x As Variant


    Application.ScreenUpdating = False
    HowMany = 1000
    Set StartCell = Range("B2")
    Set UsedGrids = CreateObject("Scripting.Dictionary")
    MyEdges = Array(xlEdgeLeft, xlEdgeRight, xlEdgeTop, xlEdgeBottom, xlInsideHorizontal, xlInsideVertical)
    
    For i = 1 To HowMany
    
        With StartCell.Resize(6, 6)
            For Each x In MyEdges
                .Borders(x).LineStyle = xlContinuous
                .Borders(x).Weight = xlThin
            Next x
        End With
        
        Do
            str1 = ""
            For r = 1 To 32
                str1 = str1 & IIf(Rnd() < 0.5, "1", "0")
            Next r
        Loop Until Not UsedGrids.exists(str1)
        
        UsedGrids(str1) = 1
        
        ctr = 1
        For r = 1 To 6
            For c = 1 To 6
                If (r = 1 Or r = 6) And (c = 1 Or c = 6) Then
                    StartCell.Offset(r - 1, c - 1).Interior.ColorIndex = 1
                Else
                    If Mid(str1, ctr, 1) = "1" Then StartCell.Offset(r - 1, c - 1).Interior.ColorIndex = 1
                    ctr = ctr + 1
                End If
            Next c
        Next r
        
        Set StartCell = StartCell.Offset(8)
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

Change the values in red to your preferences. Close the VBA editor. From your workbook, press Alt-F8, choose MakeGrids, and click Run.

It took about 2 seconds on my PC to create 1000 grids, all different. Let us know if this works for you.