Option Explicit

Sub Makros2()
Dim i As Long, lastcol As Long, dl As Long
Dim c_x1y1, c_x2y2, Color1
Dim tekst As String
Dim objtekst As Font

Static j As Long

    With ActiveSheet 'ili With Sheets("Variant 1")
        lastcol = .Range("a1").CurrentRegion.Columns.Count
        
        c_x1y1 = .Range(.Cells(2, 2), .Cells(3, lastcol)).Value
        c_x2y2 = .Range(.Cells(5, 2), .Cells(6, lastcol)).Value
        Color1 = .Range(.Cells(7, 2), .Cells(7, lastcol)).Value
        
        lastcol = lastcol - 1
        
        For i = 1 To lastcol
            j = j + 1
            
            With .Cells(8, i + 1)
                tekst = .Value
                dl = Len(tekst)
                Set objtekst = .Font
            End With
            
            .Shapes.AddShape(msoShapeRectangle, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i)).Name = "prugol" & CStr(j)
            
            With .Shapes("prugol" & CStr(j))
                With .TextFrame
                    .Characters.Text = tekst
                    With .Characters(Start:=1, Length:=dl).Font
                        .Name = objtekst.Name
                        .Size = objtekst.Size
                        .ColorIndex = objtekst.ColorIndex
                        .Italic = objtekst.Italic
                        .Bold = objtekst.Bold
                        .Underline = objtekst.Underline
                    End With
                    Set objtekst = Nothing
                End With
                
                With .Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = Cells(7, i + 1).Interior.Color
                    .Transparency = 0
                End With
            End With
        Next
    End With
End Sub

Option Explicit
Option Base 1