MS Excel

vyřešeno a ani to tak složité nebylocitovat

dotaz, našel jsem na webu toto makro. jen jsem upravit že ty obdélníky změní průhlednost což funguje, ale i v ten okamžik ztrácí info o RGB, tak když vrátím průhlednost opět na 100% (.Transparency = 0) už to má pouze jednu barvu. jde nejak ošetřit zachování RGB ?

Sub testDeleteInsertedShapes()
Dim ws As Worksheet, sh As Shape, shR As ShapeRange, rng As Range
Set ws = ActiveSheet
Set rng = ws.Range(ws.Range("A18"), ws.Cells(15, Columns.Count))

Application.EnableEvents = False
For Each sh In ws.Shapes
If sh.Type = 1 Then 'rounded rectangles
If Not Intersect(sh.TopLeftCell, rng) Is Nothing Then
If sh.TextFrame2.TextRange.Text = "Resize" Or _
sh.TextFrame2.TextRange.Text = "Clear All" Then
sh.Delete

End If
Else
sh.Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 1
.Solid
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.ObjectThemeColor = msoThemeColorAccent1
.ForeColor.TintAndShade = -0.5
.ForeColor.Brightness = 0
.Transparency = 1
End With
End If
End If
Next
Application.EnableEvents = True
End Sub

výsledek funguje

Private Sub ComboBox1_Change()
Set zacatek = Worksheets("zaklad").Range("c10:d1000").Find("V karta")
rad1 = (zacatek.Row)

Set konec = Worksheets("zaklad").Range("c10:c1000").Find("SUMÁŘ")
rad2 = (konec.Row)

Worksheets("zaklad").Cells(rad1 + 7, 6).Resize(rad2 - rad1 - 1, 1).Font.ColorIndex = 1

Dim ws As Worksheet, sh As Shape, shR As ShapeRange, rng As Range
Set ws = ActiveSheet
Set rng = ws.Range(ws.Range("A18"), ws.Cells(15, Columns.Count))
If Worksheets("data").Cells(11, 6) = "TEXT" Then
zobraz = False
Worksheets("zaklad").Cells(rad1 + 7, 6).Resize(rad2 - rad1 - 1, 1).Font.ColorIndex = 1
Else
Worksheets("zaklad").Cells(rad1 + 7, 6).Resize(rad2 - rad1 - 1, 1).Font.ColorIndex = 2
zobraz = True
End If
Application.EnableEvents = False
For Each sh In ws.Shapes
If sh.Type = 1 Then 'rounded rectangles
If Not Intersect(sh.TopLeftCell, rng) Is Nothing Then
If sh.TextFrame2.TextRange.Text = "Resize" Or _
sh.TextFrame2.TextRange.Text = "Clear All" Then
shp.Visible = zobraz
End If
Else
sh.Visible = zobraz
End If
End Ifcitovat