Excel VBA Макросы: Поместить текст из ячейки в фигуру

[Maxx]

Можно ли автоматически поместить все имеющиеся на листе данные в фигуры, которые будут расположены точно по границам ячеек, в которых есть данные.
Пример приложил: исходник - лист1, а надо, как на листе2.

[вложение удалено администратором]

[Администратор]

Макрос

Sub макрос()
   
    Dim rng As Range, arr(), shape As shape, cell As Range
    Dim i As Long, j As Long
   
   
    ' Отключение монитора для ускорения макроса.
    Application.ScreenUpdating = False
   
    '1. Присваиваем имя "rng" фрагменту, в котором есть данные и оформление.
    Set rng = ActiveSheet.usedrange
   
    '2. Копирование в массив данных из листа. С массивом быстрее работать, чем с эксель-ячейками.
    arr() = rng.Value
   
    ' Цикл по ячейкам массива "arr".
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
           
            '3. Если ячейка пустая, то переход к следующей ячейке.
            If CStr(arr(i, j)) = "" Then
                GoTo metka_NextCell
            End If
           
            '4. Присваиваем ячейке имя "cell", чтобы затем обращаться к ячейке по имени "cell".
                ' Так удобнее писать и читать код.
                ' Учитываем, что ячейка может быть объединённой.
            Set cell = rng.Cells(i, j).MergeArea
           
            '5. Вставка фигуры "прямоугольник" и присваиваем фигуре имя "shape",
                ' чтобы потом в коде обращаться к фигуре по этому имени. Так удобнее читать и писать код.
            Set shape = ActiveSheet.Shapes.AddShape(Type:=msoShapeRectangle, Left:=cell.Left, Top:=cell.Top, _
                Width:=cell.Width, Height:=cell.Height)

            '6. Уменьшение полей в надписи, чтобы текст помещался в узких фигурах.
            shape.TextFrame2.MarginLeft = 2.8346456693
            shape.TextFrame2.MarginRight = 2.8346456693
            shape.TextFrame2.MarginTop = 0
            shape.TextFrame2.MarginBottom = 0
           
            '7. Запись текста в фигуру.
            shape.TextFrame2.TextRange.Characters.text = arr(i, j)
           
metka_NextCell:
        Next j
    Next i
   
    ' Включение монитора.
    Application.ScreenUpdating = True
   
End Sub

[свернуть]

[Maxx]

Огромное спасибо!  Я думал, задачу вообще решить невозможно!

Протестировал. Почти так, как хотел. Появились вопросы:

Что нужно поправить, чтобы обрабатывалась только выделенная область?
Как можно у прямоугольников автоматически установить белый фон и убрать контур и как выровнять текст в фигуре по середине и по левому краю?

[Администратор]

По этому вопросу создайте тему:
Как можно у прямоугольников автоматически установить белый фон и убрать контур и как выровнять текст в фигуре по середине и по левому краю?

[Администратор]

Чтобы работать с выделенным фрагментом, измените пункт 1 так:
'1. Присваиваем имя "rng" выделенному фрагменту.
Set rng = Selection

Предполагается, что выделен один фрагмент без использования клавиши Ctrl.
Столбцы целиком выделять нельзя, т.к. макрос будет медленно работать; нужно выделить конкретный фрагмент. Или нужно внести изменения в макрос, если вам удобно выделять целые столбцы.

[Maxx]

Большое спасибо! Получилось очень круто!