Otomatik şekle renge göre sayısal değer atamak

[POLARIS]

Arkadaşlar iyi akşamlar,

Forumda renk işlemleri ile ilgili bir çok çalışmaya baktım.Uzman arkadaşların gerçekten çok güzel çalışmaları var.Fakat benim takıldığım nokta şu.
Otomatik şekillere de renge göre sayısal değer atamak.Ekli dosyada belirttim.Bir sayfa içerisinde yer alan çeşitli otomatik şekillerede bu işlemi yaptırabilirmiyiz?Bu mümkünmüdür?

İlgileriniz için teşekkür eder iyi çalışmalar dilerim.
İyi akşamlar.

 

[hamitcan]

Sub SekillereIndeksNoVer()
    For Each s In ActiveSheet.Shapes
        If s.Type = msoGroup Then s.Ungroup
    Next
    For Each shp In ActiveSheet.Rectangles
        If shp.Interior.Color = 855309 Then shp.Font.Color = vbWhite
        If shp.Interior.Color = vbWhite Then shp.Font.Color = vbBlack
        If shp.Interior.Color = 6299648 Then shp.Font.Color = vbWhite
        If shp.Interior.Color = vbYellow Then shp.Font.Color = vbBlack
        If shp.Interior.Color = vbRed Then shp.Font.Color = vbWhite
        shp.Select
        shp.Characters.Text = Selection.Interior.ColorIndex
    Next
End Sub

 

[POLARIS]

Sayın hamitcan,
Tamamdır.
Sizlere ne kadar teşekkür etsek az gelir.Sağlıklı ve mutlu günler dilerim.
Hoşçakalınız...

 

[POLARIS]

Sayın hamitcan tekrar merhaba,

Sizi bulmuşken bir şeyler öğreneyim.
1-Grup şekillere uygulayabilirmiyiz?
2-Diğer şekillere uygulayabilirmiyiz? Örn.daire yada başka bir şekil.
Teşekkür eder iyi çalışmalar dilerim.

 

[hamitcan]

1-Grup şekillere uygulayabilirmiyiz?

Bir kod yazdım, umarım işinizi görür.

Sub GroupSekillereİndeksNOVer()
    On Error Resume Next
    For i = 1 To Shapes.Count
        If ActiveSheet.Shapes(i).GroupItems.Count > 0 Then
            For Each shp In Shapes(i).GroupItems
                shp.Select
                Selection.Characters.Text = Selection.Interior.ColorIndex
            Next
        End If
    Next
End Sub

2-Diğer şekillere uygulayabilirmiyiz? Örn.daire yada başka bir şekil.

Evet. Bu durumda kodu biraz değiştirmek gerekecek.

 

[POLARIS]

Sayın hamitcan,
1-Grup şekillere uygulayabilirmiyiz?
Tamamdır.
Teşekkür ederim.

 

[POLARIS]

hamitcan hocam günaydın,

2-Diğer şekillere uygulayabilirmiyiz? Örn.daire yada başka bir şekil.

Diğer şekillerle ilgili olarak kodu nasıl değiştirebilir ve geliştirebiliriz?
Bu konuda yardımcı olabilirmisiniz?
Teşekkür eder iyi çalışmalar dilerim.

 

[hamitcan]

Sub SekillereİndeksNoVer()
    With ActiveSheet
        For i = 1 To .Shapes.Count
            With .Shapes(i)
                If .Type = msoGroup Then
                    For Each shp In .GroupItems
                        shp.Select
                        renk
                        Selection.Characters.Text = Selection.Interior.ColorIndex
                    Next
                Else
                    .Select
                     renk
                     Selection.Characters.Text = Selection.Interior.ColorIndex
                End If
            End With
        Next
    End With
End Sub
Sub renk()
    With Selection
            If .Interior.Color = vbBlack Then
               .Font.Color = vbWhite
            Else:
               .Font.Color = vbBlack
            End If
    End With
End Sub

 

[POLARIS]

Sayın hamitcan,
Buda Tamamdır.
Teşekkür eder Sağlıklı ve mutlu günler dilerim.
Hoşçakalınız...