Sub Макрос1()
Dim key$, o2
Dim lastcol
Dim c_x1y1, c_x2y2, Color1, Group
Dim shp

Dim shpNames() As String, shpsArr() 'массив массивов (двумерный), хранилище всех шейпов (имён)
Dim k&, n&

lastcol = Cells(2, Columns.Count).End(xlToLeft).Column

c_x1y1 = Range(Cells(2, 2), Cells(3, lastcol))
c_x2y2 = Range(Cells(5, 2), Cells(6, lastcol))
Color1 = Range(Cells(7, 2), Cells(7, lastcol))
Group = Range(Cells(8, 2), Cells(8, lastcol))

Set o2 = CreateObject("Scripting.Dictionary") ' будет флагом о том, встречали ли мы такую группу или нет

ReDim shpsArr(1 To 2, 1 To 1)
For i = 1 To lastcol - 1
    
Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, c_x1y1(1, i), c_x1y1(2, i), c_x2y2(1, i), c_x2y2(2, i)) '.Select
    With shp.Fill
        .Visible = msoTrue
        .ForeColor.RGB = Cells(7, i + 1).Interior.Color
        .Transparency = 0
    End With
    If Group(1, i) <> "" Then
        key = Group(1, i)
        If (Not o2.exists(key)) Then
            k = k + 1
            ReDim Preserve shpsArr(1 To 2, 1 To k)
            o2.Add key, k

            ReDim Preserve shpNames(1 To 1)
            shpNames(1) = shp.Name
            shpsArr(1, k) = shpNames
            
            shpsArr(2, k) = Group(1, i)
        Else
            n = UBound(shpsArr(1, o2(key))) + 1
            
            shpNames = shpsArr(1, o2(key))
            ReDim Preserve shpNames(1 To n)
            shpNames(n) = shp.Name
            shpsArr(1, o2(key)) = shpNames
        End If
    End If
Next i
For i = 1 To UBound(shpsArr, 2)
    shpNames = shpsArr(1, i)
    If (UBound(shpNames) > 1) Then
        Set gr = ActiveSheet.Shapes.Range(shpNames).Group
        gr.Name = shpsArr(2, i)
    End If
Next i
End Sub