Как сделать шестиугольные ячейки в Excel и рандомную генерацию в них?

Question

[qwertybnm]

Как сделать подобные ячейки в Excel?

Также надо сделать, чтобы при нажатии кнопки рандомно генерировалось 15-20 ячеек, в которых будет объект(в данном случае кактус)

Answer 1

[Антон Федорян]

Sub Hexagone(Row As Integer, Col As Integer, Size As Integer)
    Range(Cells(Row, Col), Cells(Row + 2, Col + 1)).Select
    With Selection
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        .Borders(xlEdgeLeft).LineStyle = xlNone
        .Borders(xlEdgeTop).LineStyle = xlNone
        .Borders(xlEdgeBottom).LineStyle = xlNone
        .Borders(xlEdgeRight).LineStyle = xlNone
        .Borders(xlInsideVertical).LineStyle = xlNone
        .Borders(xlInsideHorizontal).LineStyle = xlNone
    End With
    
    Cells(Row, Col).Select
    With Selection.Borders(xlDiagonalUp)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    Cells(Row, Col + 1).Select
    With Selection.Borders(xlDiagonalDown)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    Cells(Row + 1, Col + 1).Select
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    Cells(Row + 2, Col + 1).Select
    With Selection.Borders(xlDiagonalUp)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    Cells(Row + 2, Col).Select
    With Selection.Borders(xlDiagonalDown)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    Cells(Row + 1, Col).Select
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    
    If ((Row + 3) < (4 * Size - 1)) Then
        Cells(Row + 3, Col).Select
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlMedium
        End With
    End If
End Sub

Sub Grid()
    Dim WB As Workbook
    Dim WS As Worksheet
    Dim Size As Integer
    Dim Xn As Integer, Yn As Integer
    
    Set WB = Excel.ActiveWorkbook
    Set WS = WB.Worksheets("Ëèñò1")
    WS.Activate
    
    Size = 15
    
    Range(Cells(1, 1), Cells(4 * Size - 1, 2 * Size)).Select
    Selection.Clear
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 65535
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    Yn = 1
    For y = 1 To Size
        Xn = 1
        For x = 1 To Size
            Call Hexagone(Yn, Xn, Size)
            Xn = Xn + 2
        Next x
        Yn = Yn + 4
    Next y
    
    Randomize
    For Picture = 1 To 20
        x = Int(Size * Rnd) + 1
        y = Int(Size * Rnd) + 1
        If (y Mod 2 = 0) Then
            x = x + 1
        End If
        Cells(3 * y - 1, 2 * x - 1).Select
        ActiveSheet.Pictures.Insert( _
        "C:\Program Files (x86)\Microsoft Office\MEDIA\OFFICE14\AutoShap\BD18253_.wmf") _
        .Select
        Selection.ShapeRange.ScaleWidth 0.3016920425, msoFalse, msoScaleFromTopLeft
    Next Picture
End Sub

Примерно так. Сетка 15 * 15 и 20 рисунков.

Comments

[h8nor]

Set WS = WB.Worksheets("Ëèñò1")
Демонический копипаст. Вот кому-то заняться нечем, - такие задания раздавать.
Верный путь C:\Program Files\Microsoft Office 2010\MEDIA\OFFICE14\AUTOSHAP для файлов *.wmf.