Помогите разобраться,пожалуйста. Как вставить несколько одинаковых графических объектов? Допустим на прямоугольник из диапазона А1:G14 нужно вставить 20 звезд. Как это сделать? с одной звездой проблем нет, а как несколько не пойму. Заранее спасибо!
Private Sub CommandButton1_Click()
With Worksheets("Лист3")
.With Range("A1:G1", "A14:G14").Interior
.ColorIndex = 25
.Pattern = xlSolid
ActiveSheet.Shapes.AddShape(msoShape5pointStar, 54, 47.75, 11.25, 12#).Select
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 1
End With
End Sub
Цитата:
на прямоугольник из диапазона А1:G14
Что вы подразумеваете под прямоугольником? Лучше приложите файл с этим прямоугольником, чтобы было понятно, о чём вы пишите.
Необходимо нарисовать флаг США.
[вложение удалено администратором]
Вам останется только скорректировать лево и верх звёзд, чтобы они были так, как вам нужно.
Макрос
Private Sub CommandButton1_Click()
Dim shp As Shape
Dim lngLeft As Long, lngTop As Long, i As Long
'1. Отключение монитора для ускорения макроса.
Application.ScreenUpdating = False
'2. Оформление фрагмента "A1:G14".
With Worksheets("Лист3").Range("A1:G1", "A14:G14").Interior
.ColorIndex = 25
.Pattern = xlSolid
End With
'3. Лево и верх для первой звезды.
lngLeft = 10
lngTop = 5
'4. Вставка звёзд.
For i = 1 To 20 Step 1
'1) Вставка звёзды и присваивание звезде имени "shp". Далее к этой звезде
' можно обращаться по имени "shp".
Set shp = ActiveSheet.Shapes.AddShape(msoShape5pointStar, 54, 47.75, 11.25, 12#)
'2) Перемещение звёзды в нужную позицию.
shp.Left = lngLeft
shp.Top = lngTop
' Расчёт лева и верха для следующей звезды.
lngLeft = lngLeft + 25
' Если звёзды заняли весь ряд, то нужно переходить вниз.
If lngLeft > 315 Then
lngLeft = 10
lngTop = lngTop + 20
End If
'3) Оформление звезды.
shp.Fill.ForeColor.SchemeColor = 1
Next i
'5. Включение монитора.
Application.ScreenUpdating = True
End Sub
Огромное спасибо!!!