Create a honeycomb pattern with the hexagon shape

No Good At This

New Member
Joined
Feb 17, 2014
Messages
5
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!
 

Tom Schreiner

Well-known Member
Joined
Mar 18, 2002
Messages
6,867
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.)





 
Last edited:

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
4,696
Office Version
365
Platform
Windows
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

Code:
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)
Code:
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!
Code:
Sub DeleteShapes()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        Shp.Delete
    Next
End Sub
 
Last edited:

No Good At This

New Member
Joined
Feb 17, 2014
Messages
5
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

Well-known Member
Joined
Mar 11, 2015
Messages
4,696
Office Version
365
Platform
Windows
Don't thank me... it's Pythagoras who deserves your gratitude!
 

Forum statistics

Threads
1,082,309
Messages
5,364,425
Members
400,802
Latest member
RichBRich

Some videos you may like

This Week's Hot Topics

  • populate from drop list with multiple tables
    Hi All, i have a drop list that displays data, what i want is when i select one of those from the list to populate text from different tables on...
  • Find list of words from sheet2 in sheet1 before a comma and extract text vba
    Hi Friends, Trying to find the solution on my task. But did not find suitable one to the need. Here is my query and sample file with details...
  • Dynamic Formula entry - VBA code sought
    Hello, really hope one of you experts can help with this - i've spent hours on this and getting no-where. .I have a set of data (more rows than...
  • Listbox Header
    Have a named range called "AccidentsHeader" Within my code I have: [CODE]Private Sub CommandButton1_Click() ListBox1.RowSource =...
  • Complex Heat Map using conditional formatting
    Good day excel world. I have a concern. Below link have a list of countries that carries each country unique data. [URL...
  • Conditional formatting
    Hi good morning, hope you can help me please, I have cells P4:P54 and if this cell is equal to 1 then i want row O to say "Fully Utilised" and to...
Top