VBA Excel. Работа с фигурами (Shapes)

Работа с фигурами в VBA Excel: создание фигур методом Shapes.AddShape, типы фигур (MsoAutoShapeType), обращение к фигурам и изменение их свойств. Примеры.

Содержание

Объекты для работы с фигурами

Фигуры в VBA Excel представлены тремя объектами:

Объект	Описание
Shapes	Коллекция всех фигур на рабочем листе. Используется для создания новых фигур, для обращения к одной фигуре по имени и для перебора фигур циклом.
ShapeRange	Коллекция нескольких фигур, аргументом которой является массив имен выбранных объектов. Используется для редактирования сразу всех фигур, входящих в эту коллекцию.
Shape	Объект, представляющий одну фигуру. Используется для редактирования одной этой фигуры.

Создание фигур в VBA Excel

Фигуры в VBA Excel создаются методом Shapes.AddShape.

Синтаксис метода AddShape

1	Shapes.AddShape (Type, Left, Top, Width, Height)

Shapes — выражение, возвращающее коллекцию фигур на рабочем листе, например: ActiveSheet.Shapes.

Параметры метода AddShape

Параметр	Описание
Type	Константа из коллекции MsoAutoShapeType, определяющая тип создаваемой фигуры.
Left	Расстояние от левой границы фигуры до левой границы табличной части рабочего листа в пунктах.. Тип данных — Single.
Top	Расстояние от верхней границы фигуры до верхней границы табличной части рабочего листа в пунктах.. Тип данных — Single.
Width	Ширина фигуры по внешним границам в пунктах.
Height	Высота фигуры по внешним границам в пунктах.

Все параметры метода Shapes.AddShape являются обязательными.

Константы MsoAutoShapeType

Константы коллекции MsoAutoShapeType, определяющие основные типы создаваемых фигур:

Константа	Значение	Тип фигуры
msoShapeRectangle	1	Прямоугольник
msoShapeParallelogram	2	Параллелограмм
msoShapeTrapezoid	3	Трапеция
msoShapeDiamond	4	Ромб
msoShapeRoundedRectangle	5	Прямоугольник: скругленные углы
msoShapeOctagon	6	Восьмиугольник (октаэдр)
msoShapeIsoscelesTriangle	7	Равнобедренный треугольник
msoShapeRightTriangle	8	Прямоугольный треугольник
msoShapeOval	9	Овал
msoShapeHexagon	10	Шестиугольник (гексаэдр)
msoShapeCross	11	Крест
msoShapeRegularPentagon	12	Пятиугольник (пентаэдр)
msoShapeCan	13	Цилиндр
msoShapeCube	14	Куб
msoShapeDonut	18	Круг: прозрачная заливка (кольцо)
msoShapeLightningBolt	22	Молния
msoShapeSun	23	Солнце
msoShapeMoon	24	Месяц (луна)
msoShape5pointStar	92	Звезда: 5 точек (пятиконечная)
msoShapeCloud	179	Облако

Все доступные константы из коллекции MsoAutoShapeType смотрите на сайте разработчиков.

Создание объекта ShapeRange

Создание коллекции ShapeRange из выбранных фигур:

1 2	Dim myShapeRange As ShapeRange Set myShapeRange = ActiveSheet.Shapes.Range(Array("Пятиугольник 140", "Солнце 141", "Облако 144"))

Объектная переменная myShapeRange не обязательна, можно обратиться непосредственно к возвращенной коллекции, например, присвоив всем ее элементам синий цвет:

1	ActiveSheet.Shapes.Range(Array("Пятиугольник 140", "Солнце 141", "Облако 144")).Fill.ForeColor.RGB = vbBlue

Примеры работы с фигурами

Пример 1

Создание пяти разных фигур из кода VBA Excel методом Shapes.AddShape:

Sub Primer1()

With ActiveSheet.Shapes

'При создании фигуры без присвоения ее переменной скобки не нужны

.AddShape msoShapeCube, 30, 40, 72, 72

.AddShape msoShapeIsoscelesTriangle, 130, 40, 72, 72

.AddShape msoShapeSun, 230, 40, 72, 72

.AddShape msoShapeLightningBolt, 330, 40, 72, 72

'Чтобы выбрать фигуру, параметры необходимо заключить в скобки

.AddShape(msoShapeCloud, 430, 40, 72, 72).Select

End With

End Sub

Результат работы кода:

Фигуры на листе Excel

Пример 2

Работа с одной фигурой:

Sub Primer2()

Dim myShape As Shape

'Создаем фигуру "Месяц" и присваивает ссылку на нее переменной myShape

Set myShape = ActiveSheet.Shapes.AddShape(msoShapeMoon, 50, 50, 80, 80)

With myShape

'Меняем высоту и ширину фигуры

.Height = 150

.Width = 100

'Меняем цвет фигуры

.Fill.ForeColor.RGB = vbYellow

'Поворачиваем фигуру влево на 40 градусов

.Rotation = -40

End With

End Sub

Пример 3

Редактирование одновременно нескольких фигур с помощью коллекции ShapeRange:

Sub Primer3()

With ActiveSheet.Shapes.Range(Array("Овал 1", "Овал 2", "Овал 3"))

'Меняем цвет всех фигур из коллекции ShapeRange

.Fill.ForeColor.RGB = vbBlue

'Задаем высоту и ширину овалов

.Height = 150

.Width = 50

'Поворачиваем фигуры вправо на 45 градусов

.Rotation = 45

End With

End Sub

Пример 4

Редактирование одновременно всех фигур на рабочем листе с помощью коллекции ShapeRange:

Sub Primer4()

Dim myShapeRange As ShapeRange, i As Integer, _

myShape As Shape, myArray() As String

'Задаем массиву размерность от 1 до количества фигур на листе

ReDim myArray(1 To ActiveSheet.Shapes.Count)

'Проходим циклом по всем фигурам коллекции и записываем их имена в массив

For Each myShape In ActiveSheet.Shapes

i = i + 1

myArray(i) = myShape.Name

'Создаем коллекцию ShapeRange и присваиваем ссылку на нее переменной myShapeRange

Set myShapeRange = ActiveSheet.Shapes.Range(myArray)

With myShapeRange

'Изменяем цвет всех фигур на рабочем листе

.Fill.ForeColor.RGB = RGB(100, 150, 200)

'Поворачиваем все фигуры вокруг вертикальной оси

.Flip msoFlipVertical

End With

End Sub

Пример 5

Добавление надписи (текста) на фигуру:

Sub Primer5()

Dim myShape As Shape

Set myShape = ActiveSheet.Shapes.AddShape(msoShapeCloud, 50, 30, 300, 300)

With myShape.TextFrame2

'Добавление текста на фигуру

.TextRange.Characters.Text = "Объект TextFrame представляет текстовую рамку в объекте Shape. Содержит текст в текстовом кадре, а также свойства и методы, которые контролируют выравнивание и закрепление текстового кадра."

'Задаем курсивное начертание

.TextRange.Characters.Font.Italic = True

'Указываем размер шрифта

.TextRange.Characters.Font.Size = 13

'Отступ левой границы текстового поля от левой внутренней границы фигуры

.MarginLeft = 30

'Отступ верхней границы текстового поля от верхней внутренней границы фигуры

.MarginTop = 20

End With

End Sub

Результат работы кода:

Фигура Облако с надписью

Изменить цвет текста, например на черный, можно двумя способами:

'С помощью константы MsoThemeColorIndex

myShape.TextFrame2.TextRange.Characters.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1

'С помощью цветовой модели RGB

myShape.TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = RGB(0, 0, 0)

С константами из коллекции MsoThemeColorIndex вы можете ознакомиться на сайте разработчиков.

Пример 6

Удаление фигур с рабочего листа из кода VBA Excel с помощью метода Delete.

Удаление одной фигуры:

1	ActiveSheet.Shapes("Ромб 5").Delete

Удаление нескольких фигур:

1	ActiveSheet.Shapes.Range(Array("Овал 1", "Овал 2", "Овал 3")).Delete

Удаление всех фигур с рабочего листа с помощью цикла:

Sub Primer6()

Dim myShape As Shape

For Each myShape In ActiveSheet.Shapes

myShape.Delete

End Sub

В 7 примере рассмотрено удаление всех фигур без цикла.

Пример 7

Выделение всех фигур на рабочем листе:

1	ActiveSheet.Shapes.SelectAll

Выбор всех фигур и удаление выбранного (всех фигур):

Sub Primer7()

ActiveSheet.Shapes.SelectAll

Selection.Delete

End Sub

Продолжение темы в статье VBA Excel. Копирование, перемещение и поворот фигур.

Содержание рубрики VBA Excel по тематическим разделам со ссылками на все статьи.

98 комментариев для “VBA Excel. Работа с фигурами (Shapes)”

Сбитый Лётчик Небосводов 13.01.2022 в 15:19

Здравствуйте!
Можно ли константы MsoAutoShapeType задавать переменными?
Что-то у меня не получается. Как ни пробую, всё Run-time error ’13’: Type mismatch.

Евгений 13.01.2022 в 17:17

Добрый вечер!
У меня работает:

Sub Test1()

Dim myArr, i As Byte

myArr = Array(1, 13, 28, 44, 56)

With ActiveSheet.Shapes

For i = 1 To 5

.AddShape myArr(i - 1), i * 100 - 70, 40, 72, 72

End With

End Sub

То же самое при использовании текстовых значений констант MsoAutoShapeType:

Sub Test2()

Dim myArr, i As Byte

myArr = Array(msoShapeOctagon, msoShapeOval, msoShapeDonut, msoShapeSun, msoShapeCloud)

With ActiveSheet.Shapes

For i = 1 To 5

.AddShape myArr(i - 1), i * 100 - 70, 40, 72, 72

End With

End Sub

Сбитый Лётчик Небосводов 13.01.2022 в 18:08

Спасибо, лучший друг VBAшника Евгений!
У меня не работает при str = «msoShapeOctagon» и .AddShape str,…
Ваше решение меня выручает.
Сбитый Лётчик Небосводов 13.01.2022 в 19:48

Можно ли наносить на Shapes надписи? И как, если да?
Не могу найти, а нужно срочно. Можно, разумеется ответить ссылкой.
1. Сбитый Лётчик Небосводов 13.01.2022 в 21:53
  
  Можно.
  
  1
  
  Лист.Shapes(№ фигуры).TextFrame2.TextRange.Characters.Text = Cells(a,b) & Chr(10) & Cells(c,d)
2. 1. Евгений 13.01.2022 в 23:56
    
    Спасибо! Добавлю в статью.
  2. 1. Сбитый Лётчик Небосводов 14.01.2022 в 06:49
      
      Добавил бы
      
      1
      
      .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccentЦифра
0mega 30.01.2022 в 12:30

здравствуйте
Если вопрос не по теме — просьба перенести в соответствующий раздел.
На рабочем Листе есть фигуры/картинки/фотографии…
которым присвоены свои имена («Прямоугольник 1», «Рисунок 2″…)
при копировании (внутри листа) они получают новые имена (фигура 12; рисунок 4 …)
У меня 2-а вопроса:
1) как макросом определить наименование картинки которая расположена в диапазоне D3:F5 ?
2) при изменении размера, встроенный компилятор показывает код:

1
2

Selection.Name = "Группа 2"
Selection.ShapeRange.ScaleWidth 1.5079442958, msoFalse, msoScaleFromTopLeft

какой написать код , чтобы машина выполняла действия ( изменение размера) без Selection ?

Евгений 30.01.2022 в 12:52

Добрый день, 0mega!
1) Как макросом определить наименование картинки, которая расположена в диапазоне D3:F5?
Так можно найти фигуру, левая верхняя точка которой находится в диапазоне D3:F5:

Sub Test()

Dim myShape As Shape

For Each myShape In ActiveSheet.Shapes

With myShape

If .Left >= Range("D3").Left And .Left < Range("G6").Left _

And .Top >= Range("D3").Top And .Top < Range("G6").Top Then

MsgBox .Name

Exit For

End If

End With

End Sub

2) Какой написать код , чтобы машина выполняла действия (изменение размера) без Selection?

ActiveSheet.Shapes("Прямоугольник 1").ScaleWidth 1.5, msoFalse

ActiveSheet.Shapes("Прямоугольник 1").ScaleHeight 1.5, msoFalse

'или

ActiveSheet.Shapes("Прямоугольник 1").Width = 200

ActiveSheet.Shapes("Прямоугольник 1").Height = 200

0mega 30.01.2022 в 16:14

спасибо,
а как можно изменить имя напр. «Прямоугольник 1» — «figure12» ?

0mega 30.01.2022 в 16:18

можно ли скопировать и сразу переименовать фигуру ?
Евгений 30.01.2022 в 17:02

ActiveSheet.Shapes(«Прямоугольник 1»).Name = «figure12»

Евгений 30.01.2022 в 17:45

Sub Test()

Sheets("NewSheet").Shapes("Прямоугольник 1").Copy

Sheets("Лист12").Paste

Sheets("Лист12").Select

Selection.Name = "figure12"

End Sub

GWolf 17.02.2022 в 21:30

Добрый день!
Как соединить кодом VBA две фигуры соединительной линией так, чтобы при перемещении одной из фигур соединитель не отрывался от нее?
Надир 06.05.2022 в 00:09

Есть два объекта shapes. В одном стоит цифра. надо читать эту цифру и на основе цифры написать на другой объект shapes определенный текст. Заранее спасибо.

Евгений 07.05.2022 в 02:02

Привет, Надир!
Примерный код может быть таким:

Sub Test1()

Dim myShape1 As Shape, myShape2 As Shape

Set myShape1 = ActiveSheet.Shapes("Овал 1")

Set myShape2 = ActiveSheet.Shapes("Овал 2")

If myShape1.TextFrame2.TextRange.Characters.Text = 1 Then

myShape2.TextFrame2.TextRange.Characters.Text = "Первый текст"

ElseIf myShape1.TextFrame2.TextRange.Characters.Text = 2 Then

myShape2.TextFrame2.TextRange.Characters.Text = "Второй текст"

ElseIf myShape1.TextFrame2.TextRange.Characters.Text = 3 Then

myShape2.TextFrame2.TextRange.Characters.Text = "Третий текст"

Else

myShape2.TextFrame2.TextRange.Characters.Text = "Текст для остальных случаев"

End If

End Sub

Юрий 30.05.2022 в 21:49

Добрый день. Подскажите, пожалуйста, как для автофигуры назначить нажатие? Задача такая, что если по нажатию на автофигуру срабатывал бы код Application.CommandBars.FindControl(ID:=1605).Execute, а при втором нажатии срабатывал бы код Application.CommandBars.FindControl(ID:=1605).Reset
Буду очень благодарен.

Евгений 31.05.2022 в 21:51

Здравствуйте, Юрий!
Объявите переменную уровня модуля типа Boolean. При открытии файла, она будет иметь значение False. Пример кода:

Dim b As Boolean

Sub Test1()

If b = False Then

Application.CommandBars.FindControl(ID:=1605).Execute

b = True

Else

Application.CommandBars.FindControl(ID:=1605).Reset

b = False

End If

End Sub

Григорий 15.07.2022 в 19:22

Добрый день!
Вот так на Активном листе создаются прямоугольники (один запуск — один прямоугольник) один под другим:

Sub addShape()

'создаем прямоугольники, один под другим

Dim shp As Shape

Dim shlLeft As Single, shlTop As Single, shlWidth As Single, shlHeight As Single

With ActiveSheet

Dim valN As Integer: valN = 0: valN = .Cells(2, 2).Value: If valN = 0 Then valN = 1

If valN > 1 Then 'если есть хотя бы одна Shape

For Each shp In .Shapes

If shp.Name = "Rectangle " & valN - 1 Then '

shlTop = shp.Top + shp.Height + 5

Exit For

End If

shlLeft = shp.Left

shlWidth = shp.Width

shlHeight = shp.Height

Else 'если Shape отсутствуют, то

'устанавливаем начальные координаты размещения

shlLeft = 60 '- по X

shlTop = 40 '- по Y

'и размер фигуры

shlWidth = 100 '- длина

shlHeight = 25 '- высота

End If

'выражение. AddShape (Type, Left, Top, Width, Height)

.Shapes.addShape(msoShapeRectangle, shlLeft, shlTop, shlWidth, shlHeight).Name = "Rectangle " & valN

.Cells(2, 2) = valN + 1

With .Shapes("Rectangle " & valN)

.Fill.ForeColor.RGB = RGB(0, 110, 102) ' - заливка поля цветом (светло-зеленый)

.Line.ForeColor.SchemeColor = 12

End With

End Sub

а вот так я их удаляю:

Sub dellAllShape()

'удаление всех Shape с активного листа

Dim shp As Shape

With ActiveSheet

For Each shp In .Shapes

If shp.Type = msoAutoShape Then

With shp

.Select

ySNo = MsgBox("Удалить выделенную фигуру?", vbQuestion + vbYesNoCancel, "Фигура: " & .Name)

.Select

If ySNo = 7 Then '- Нет

.TopLeftCell.Select

ElseIf ySNo = 6 Then '- Да

.TopLeftCell.Select

.Select

.Delete

Else '- Завершить (2)

.TopLeftCell.Select

Exit For

End If

End With

End If

.Cells(2, 2).Clear

End With

End Sub

Вопрос: нужно чтобы прямоугольник, сначала выделялся, затем шел диалог запроса: Удалять-Оставить-Завершить.
Удаляет и оставляет и завершает, но … с выделением уже голову сломал. Может кто подскажет: что не так?

1. Евгений 17.07.2022 в 01:18
  
  Здравствуйте, Григорий!
  Попробуйте после With shp вместо .Select вставить следующую строку:
  
  1
  2
  
  With shp
  ActiveSheet.Shapes(.Name).Select
Антон 05.09.2022 в 15:27

А есть возможность перемещать фигуры? То есть менять их координаты?
1. Евгений 06.09.2022 в 17:47
  
  Добрый вечер, Антон!
  Перемещать фигуры можно:
  
  1
  2
  3
  4
  5
  6
  
  Sub Primer()
      With Лист10.Shapes("Овал 1")
          .Left = 100
          .Top = 50
      End With
  End Sub
Артём 13.09.2022 в 15:36

Добрый день.
Как можно фигуру (в моём случае это картинка на листе) назначить как картинку или фон для пользовательской формы?
1. Евгений 13.09.2022 в 21:06
  
  Здравствуйте, Артём!
  По-моему, это невозможно.
Александр 02.10.2022 в 06:20

Здравствуйте. А можно как-нибудь удалить строку, если в ячейке нет объекта Shape&
Александр 05.10.2022 в 12:50

Здравствуйте, есть ли возможность присвоить имя в ячейке для объекта SHAPE?

Евгений 05.10.2022 в 13:57

Добрый день, Александр!
Вы хотите слово, записанное в ячейку, присвоить в качестве имени объекту Shape?

Александр 05.10.2022 в 15:16

Добрый день. Нужно, чтоб в ячейке, куда вставляется объект Shape вставлялось еще наименование данного объекта

Евгений 05.10.2022 в 18:43

Не знаю, как вы вставляете фигуру в ячейку, но если привязать ее по координатам, то имя фигуры можно присвоить значению ячейки следующим образом:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

With Shapes(1)

.Left = Target.Left + 40

.Top = Target.Top

Target.Value = .Name

End With

End Sub

Для любого случая:

Sub Test()

Range("A1") = Лист10.Shapes(1).Name

End Sub

1. Александр 06.10.2022 в 11:15
  
  Спасибо! Помогло!

ЕвгенияУ 02.12.2022 в 12:13

Добрый день! У вас в статье приведены примеры с внесением текста в фигуру. Я вижу что текст не в одну строку в фигуре, а переносится по словам на следующие строки. Объясните, пожалуйста, как это сделано? Только, пожалуйста, простыми словами (. Я макросами никогда не занималась, и разбираю чужой макрос.
1. Евгений 02.12.2022 в 12:53
  
  Здравствуйте, Евгения!
  В моем примере текст переносится по словам по умолчанию.
  Отмена переноса текста по словам:
  
  1
  
  Shape.TextFrame2.WordWrap = msoFalse
  
  где Shape — выражение, возвращающее фигуру, например, Shapes(1), Shapes(«Ромб 1»), или, как в моем примере, это может быть переменная (myShape).
  Поищите в своем макросе строку с текстом .WordWrap = msoFalse и закомментируйте ее.
  А так можно задать перенос текста по словам из кода макроса:
  
  1
  
  Shape.TextFrame2.WordWrap = msoTrue
2. 1. ЕвгенияУ 02.12.2022 в 14:11
    
    Фразы такой в макросе не нашла. Видите-ли в чем дело, ранее перенос не требовался, т.к. текст был коротким. Теперь текст увеличился и выходит далеко за границы страницы вообще. Этот текст макрос переносит с первой страницы во все остальные(своего рода заполнение штампа). И так понимаю что функция переноса просто не вписана вообще. Я вписалась то что вы мне прислали
    Shape.TextFrame2.WordWrap=msoTrue.
    В ответ он пишет «Ошибка компиляции. Переменная не определена». Фразу я эту вписала последней строкой после строк заполнения штампа(заполнения граф).
  2. 1. Евгений 02.12.2022 в 14:27
      
      Вам надо заменить слово Shape на то имя фигуры, которое используется в вашем макросе.
    2. 1. ЕвгенияУ 05.12.2022 в 12:23
        
        Добрый день, Евгений! К сожалению у меня все равно ничего не получается. Либо я не туда вписываю программную строку, либо не вписываю вместо Shape. Я сделал отдельный макрос (просто отредактировал текст в фигуре через «формат фигуры»), но при выводе на печать он сбрасывает все(.
Дмитрий 03.12.2022 в 23:54

Добрый день!

Как задать ширину и длину объекта в см на основании значения определенных ячеек?

Евгений 04.12.2022 в 02:09

Здравствуйте, Дмитрий!
Высота и ширина фигур задаются в пунктах. В 1 см содержится приблизительно 28.35 пунктов:

Sub Test()

With ActiveSheet.Shapes("Овал 1")

.Width = Range("C1") * 28.35

.Height = Range("C2") * 28.35

End With

End Sub

0mega 07.12.2022 в 22:54

здравствуйте
на рабочем листе имеется картинка "Sred"
Верхний левый угол этой картинки надо припарковать в D5
ActiveSheet.Shapes.Range(Array("Sred")).Copy Range("d5")
Такую команду машина игнорирует и картинка остается на своем месте
Range("D5") = Shapes("Sred")
здесь тоже.
Как переместить картинку в нужную ячейку ?
P.S.
IncrementLeft/Top не подходят потому что адрес назначения имеет RND
Вставлять надо именно в адресную ячейку
1. Евгений 08.12.2022 в 00:16
  
  Привет!
  
  1
  2
  3
  4
  5
  6
  
  Sub Test()
      With ActiveSheet.Shapes("Sred")
          .Left = Range("D5").Left
          .Top = Range("D5").Top
      End With
  End Sub
0mega 14.12.2022 в 12:36

Евгений, с наступающим

Имеется книга "E_N".В ней несколько листов. Нас интересуют два листа "Sv" и последний лист.
На Листе "Sv" есть фигура "Sun".
Макрос должен скопировать "Sun" и вставить на последний лист в ячейку F7
Ничего сложного.
Такой макрос обычный макрорекордер запишет, но есть одно условие
Копировать/вставлять надо без Selection

Евгений 14.12.2022 в 14:14

Добрый день!

Sub Test()

Sheets("Sv").Shapes("Sun").Copy

With Sheets(ThisWorkbook.Sheets.Count)

.Paste

.Shapes(.Shapes.Count).Left = .Range("F7").Left

.Shapes(.Shapes.Count).Top = .Range("F7").Top

End With

End Sub

0mega 14.12.2022 в 14:59

спасибо.
всё работает как надо

Евгений , мысли вслух… (можно и не публиковать )
почему бы вам не организовать свой Excel-форум.
Подобрать пару-тройку грамотных модераторов и я думаю что вы не долго будете «в тени»
ЕвгенияУ 16.12.2022 в 09:50

Евгений, здравствуйте! Я все перепробовала-у меня ничего не получилось. Могу ли я Вам как-то показать макрос, который строит штамп и вносит туда данные?

Евгений 16.12.2022 в 17:34

Здравствуйте, Евгения!
Вставьте ваш макрос в комментарий. Если в нем есть конфиденциальная информация, замените ее незначащим текстом.

ЕвгенияУ 05.01.2023 в 20:55

Здравствуйте, Евгений!
Я Вам написала в комментариях макрос, пока правда он еще что-то не отобразился(

Евгений 05.01.2023 в 22:42

Здравствуйте, Евгения!
Макрос пришел, я посмотрю его.
Евгений 06.01.2023 в 00:10

Евгения, попробуйте заменить строку

1

.TextFrame.AutoSize = True 'Разрешаем авторасширение

на

1

.TextFrame.AutoSize = False 'Запрещаем авторасширение

ЕвгенияУ 06.01.2023 в 00:30

Спасибо большое! Как выйду с выходных попробую.
ЕвгенияУ 09.01.2023 в 09:24

Евгений, доброе утро! К сожалению то что вы предложили не сработало. Текст не переносится на следующую строчку.

Евгений 09.01.2023 в 10:20

Здравствуйте, Евгения!
Тогда попробуйте заменить ту же строку

1	.TextFrame.AutoSize = True 'Разрешаем авторасширение

на

.TextFrame.AutoSize = False 'Запрещаем авторасширение

.Width = 150 'Задаем ширину надписи

.Height = 50 'Задаем высоту надписи

.TextFrame2.WordWrap = True 'Разрешаем перенос по словам

Если получится, установите нужные значения ширины и высоты надписи.

ЕвгенияУ 09.01.2023 в 10:43

Спасибо большое, Евгений! Заработало! Но работает во всех строках кроме "один", там почему-то не переносит.

Евгений 09.01.2023 в 12:54

Евгения, попробуйте выполнить главную процедуру, которая все запускает, в режиме отладки. Вставьте в нее курсор и нажимайте клавишу F8 для пошагового исполнения кода. Вы увидите после какой строки кода будет создана надпись "один" и что ей предшествовало, и как будут создаваться последующие надписи, в чем будет разница с созданием первой.

ЕвгенияУ 09.01.2023 в 14:05

В коде относящемся к «один» почему-то выпадает строка
.name=name ‘имя ячейки.
1. Евгений 09.01.2023 в 16:38
  
  Закомментируйте строки с If в этом блоке:
  
  1
  2
  3
  
  'If Name <> "" Then
  .Name = Name 'имя ячейки
  'End If
ЕвгенияУ 10.01.2023 в 13:37

Евгений, здравствуйте! Все просмотрела через F8, везде все операции одинаковы и последовательность их выполнения одинакова, но в поле «один» текст так и не переносится(.
1. Евгений 10.01.2023 в 20:05
  
  Здравствуйте, Евгения! А вы закомментировали строки с If?
ЕвгенияУ 11.01.2023 в 18:42

Здравствуйте, Евгений!
Да, закомментировала ( ну если все правильно сделала)
If name""Then '... .name=name 'имя ячейки End If '...
Отличие в выполнении команд по полю «один» и остальных заключается в:
name="один" addUnitLabel ws,10*0,10*0,500,10,True,name,getCellValue(name)
в слове True. Все остальные False. Я несколько раз все пересмотрела и сравнила. Только в этом отличие.

Евгений 11.01.2023 в 20:40

Евгения, вы неправильно закомментировали строки с If — апострофы должны стоять перед If и End:

1
2
3

'If Name <> "" Then
.Name = Name 'имя ячейки
'End If

True задает полужирное начертание, если оно вам не нужно, замените на False.
ЕвгенияУ 12.01.2023 в 09:10

Здравствуйте, Евгений! Извините, я просто никогда vba не занималась(.
Я закомментировала как вы сказали, и теперь строка
.name=name ‘имя ячейки
высвечивается как ошибка (выделена жёлтым).
Евгений 12.01.2023 в 16:35

Евгения, отмените комментирование строк с If. Откройте «Диспетчер имен» на вкладке «Формулы» и посмотрите, есть ли там имена «один», «два», «три» и т.д. Возможно, среди всех имен, у вас нет имени «один», поэтому строка .name = name на имени «один» пропускается.
Евгений 12.01.2023 в 16:48

Если в «Диспетчере имен» есть имя «один», значит ячейка с этим именем пустая, посмотрите адреса именованных ячеек и что в них записано. Возможно, вам просто нужно вписать нужный текст в ячейку с именем «один».
ЕвгенияУ 13.01.2023 в 14:53

Добрый день, Евгений!
Фразы с if раскомментировала.
В «диспетчере имен» есть все поля. У них у всех есть, имя, значение, диапазон и область. Данные в саму ячейку внесены, иначе я не смогла бы заметить что там не переносится информация.
Теперь при использовании F8 все поля выполняются одинаковыми функциями, нет ни одного отличия. Строчка с name присутствует в выполнении программы в каждом поле. Но проблема с переносом текста в поле «один» так и осталась.
Евгений 16.01.2023 в 13:34

Здравствуйте, Евгения!
Текст в поле «один» не вставляется или вставляется, но не переносится по словам?
ЕвгенияУ 16.01.2023 в 14:04

Евгений, здравствуйте! Текст в поле «один» вставляется, но перенос на другую строку не происходит и он наползает на поле «пять». В поле «один» и «два» цифровые значения, в остальных буквенные.
Евгений 16.01.2023 в 15:05

А между цифрами в поле «один» встречаются пробелы? Цифры печатаются в поле «один» полужирным шрифтом?
ЕвгенияУ 16.01.2023 в 15:12

В поле «один» идёт некоторый набор цифр, перечисление, через запятые. Так же как и в поле «два». Полужирное написание в поле «один» есть.

Евгений 16.01.2023 в 16:48

Закомментируйте строки

1 2	'.Width = 100 'Задаем ширину надписи '.Height = 50 'Задаем высоту надписи

вставьте под ними

If name = "один" Then

.Width = 100 'Задаем ширину надписи

.Height = 50 'Задаем высоту надписи

Else

.Width = 150 'Задаем ширину надписи

.Height = 50 'Задаем высоту надписи

End If

И посмотрите что получится.

ЕвгенияУ 17.01.2023 в 22:30

Евгений, здравствуйте! Спасибо Вам огромное! Вы просто гений и супер знаток. Все заработало как надо!!!

Александр 20.12.2022 в 10:38

А как выделить все фигуры на активном листе через vba?
1. Евгений 20.12.2022 в 17:11
  
  1
  
  ActiveSheet.Shapes.SelectAll
АндрейК 09.01.2023 в 14:24

Добрый день. Подскажите, как создать фигуру без фона. В примере 2 ".Fill.ForeColor.RGB = vbYellow" вместо vbYellow какое значение нужно поставить? И можно ли создать фигуру с помощью макроса, которая не будет перемещаться и изменять свой размер вместе с ячейками.

АндрейК 09.01.2023 в 14:52

С фигурой без фона разобрался.
Записал и фон стал прозрачным.
.Fill.ForeColor.RGB = RGB (255,255,255) .Fill.Transparency = 1
А вот чтобы фигура не изменяла свой размер при изменении размера ячейки не получается. Если есть такая возможность, подскажите пожалуйста

Евгений 09.01.2023 в 16:14

Здравствуйте, Андрей!
Фигура перемещается с ячейкой, но размеры не изменяет:

1

ActiveSheet.Shapes("Блок-схема 2").Placement = xlMove

А чтобы фигура вообще оставалась на месте:

1

ActiveSheet.Shapes("Блок-схема 2").Placement = xlFreeFloating

АндрейК 09.01.2023 в 16:29

Спасибо большое. Получилось
АндрейК 09.01.2023 в 16:43

Еще подскажите. Как это свойствам применить не нескольким созданным объектам? Как у вас идет обращение к «Блок-схема 2» (на сколько я понимаю это группа объектов). Как нескольким объектам присвоить одну группу

Евгений 09.01.2023 в 17:16

«Блок-схема 2» — это одна фигура. Как изменить свойства одновременно у нескольких фигур показано в примерах 3 и 4.

АндрейК 10.01.2023 в 09:53

Спасибо разобрался. И надеюсь последний вопрос: можно ли задать поля для надписи внутри фигуры. Когда смотрю свойства созданной фигуры, в параметрах «Надпись» установлены значения по умолчанию: 0,25/0,25/0,13/0,13см (левое/правое/верхнее/нижнее поле). Возможно ли в макросе задать эти значения (необходимо везде 0см установить). Либо если текст не помещается в фигуре, автоматически подогнать размер шрифта.

Евгений 10.01.2023 в 10:12

With ActiveSheet.Shapes("Блок-схема 2")

.TextFrame2.MarginLeft = 0

.TextFrame2.MarginRight = 0

.TextFrame2.MarginTop = 0

.TextFrame2.MarginBottom = 0

End With

1. АндрейК 10.01.2023 в 10:16
  
  Огромное спасибо. Очень помогли

АндрейК 10.01.2023 в 16:48

Прошу прощения, что возвращаюсь к закрытому вопросу, но хотел бы все таки у Вас узнать. Возможно ли полностью удалить заливку у фигуры с помощью макроса? Создав фигуру с заливкой и убрав ее с помощью добавления прозрачности решается только часть проблемы. Когда фон у фиругы убран с помощью прозрачности, ячейки под фигурой становятся видимы, но выделить ячейку все равно проблематично, потому что нажав на ячейку внутри фигуры выделяться фигуру, а не ячейка. Когда в ручную полностью отключается фон (в свойствах выбираю «нет заливки»), то перемещение по ячейкам внутри фигуры производится в обычном режиме (как будто фигуры и нету на листе).
Подытожив, задача заключается в том, чтобы на листе была рамка, но работа с ячейками внутри рамки осуществлялась в обычном режиме.
Прошу прощения за много текста, но надеюсь удалось объяснить суть моего вопроса. За ранее благодарен
1. Евгений 10.01.2023 в 21:20
  
  Это не сложно:
  
  1
  
  ActiveSheet.Shapes("Блок-схема 2").Fill.Visible = msoFalse

Обсуждение закрыто.