Sub Макрос1()
arr = Cells(4, 3).CurrentRegion.Value
    For i = 2 To UBound(arr)
        If Not IsEmpty(arr(i, 2)) Then
            Select Case arr(i, 2)
                Case "Овал": tip = msoShapeOval
                Case "Ромб": tip = msoShapeDiamond
                Case "Прямоугольник": tip = msoShapeRectangle
                Case "Равнобедренный треугольник": tip = msoShapeIsoscelesTriangle
                Case "Шестиугольник": tip = msoShapeHexagon
            End Select
            
            If Not IsEmpty(tip) Then
                With ActiveSheet.Shapes.AddShape(tip, 20 + i * 10, 10 + i * 10, arr(i, 4), arr(i, 3))
                    .DrawingObject.Caption = arr(i, 5)
                    .Name = arr(i, 2) & " " & arr(i, 1)
                End With
                tip = Empty
            End If
        End If
    Next
End Sub