Create a honeycomb pattern with the hexagon shape

[No Good At This]

Hi,

How can I automatically create a tessellated honeycomb pattern on a sheet, using the hexagon shape?

Ideally, I want to be able to use 2 variables for row & column and create a honeycomb based on those values

I hope this makes sense!

 

[Legacy 98055]

tes·sel·late
/ˈtesəˌlāt/

verb
past tense: tessellated; past participle: tessellated

1. decorate (a floor) with mosaics.
   • MATHEMATICS

cover (a plane surface) by repeated use of a single shape, without gaps or overlapping


I had to look that one up.
Does the pic resemble what you are after? If so, are you expecting it to be redrawn automatically by entering the row and column numbers? (The 2 should be a 3 but I'm not gonna redo the screen shot.)

 

[No Good At This]

I can't see the pic sorry, so I'll try to put one in this message to explain....https://photos.app.goo.gl/2hHjddGTWsi4eAG17

This would be created if the user entered "2" for rows and "3" for columns

I hope this makes sense

 

[Yongle]

Here is something to get you started
- test in a new workbook
- place all 3 procedures in the same module
- click OK on every inputbox first time to confirm it runs all the way through
- then try amending the values

- amend to suit your needs

Sub CreateHoneycomb()
[COLOR=#008080]'variables[/COLOR]
    Dim firstCell As Range, Shp As Shape
    Dim LeftMost As Double, TopMost As Double, L As Double, T As Double, W As Double
    Dim c As Long, r As Long, colCount As Long, rowCount As Long
[COLOR=#008080]'ask user for details[/COLOR]
    W = InputBox("width of each hexagon?", "", 30)
    colCount = InputBox("how many hexagons across?", "", 10)
    rowCount = InputBox("how many hexagons down?", "", 25)
    Application.InputBox("Cick on first cell", "Start of comb", "A1", , , , , 8).Activate
[COLOR=#008080]'determine left and top of range[/COLOR]
    Set firstCell = ActiveCell
    TopMost = firstCell.Top
    LeftMost = firstCell.Left
[COLOR=#008080]'create honeycomb[/COLOR]
    For c = 0 To colCount - 1
        For r = 0 To rowCount - 1
            T = TopMost + r * W                               [COLOR=#008080]  'shape TOP[/COLOR]
            If c Mod 2 = 1 Then T = T + W / 2
            L = LeftMost + (0.75 * c * W)                       [COLOR=#008080]'shape LEFT[/COLOR]
            Set Shp = ActiveSheet.Shapes.AddShape(msoShapeHexagon, L, T, W, W)
            [COLOR=#008000]AmendShapeProperties[/COLOR] Shp
        Next r
    Next c
    firstCell.Activate
End Sub

one way to amend shape properties (it is called from main sub)

Private Sub [COLOR=#008000]AmendShapeProperties[/COLOR](aShape As Shape)
        aShape.Select
        With Selection.ShapeRange.Fill
            .ForeColor.ObjectThemeColor = msoThemeColorBackground1
            .Solid
        End With
End Sub

always useful to be able to delete them all after testing each time!

Sub DeleteShapes()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        Shp.Delete
    Next
End Sub

 

[No Good At This]

Thank you!! That is majorly impressive, I couldn't get my head around how to space them like that.

That's perfect, thanks again

 

[Yongle]

Don't thank me... it's Pythagoras who deserves your gratitude!