Форум по VBA и MS Office

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