Renkli Hücre Toplamı

[TİKOS]

Arkadaşlar,
Sizden ricam Kod yazan sütundaki kodlara göre örneğin
IP5 olan yeşil renkli hücreleri toplasın. Sarıları toplamasın.

Yardımcılarınızı rica ediyorum.
Teşekkürler

 

[asi_kral]

Merhaba
Boş bir module kopyalayın ve deneyin.

Option Explicit
Sub renkli_say()
Dim STR As Long, HCR As Range, SYM As Long
Dim SBT As Variant
Application.ScreenUpdating = False
For STR = 12 To Cells(Rows.Count, "B").End(xlUp).Row
SYM = 0
If Cells(STR, "B") <> Empty And Cells(STR, "B") = "TOPLAM" Then
Set HCR = Range("B5:CF11").Find(Cells(STR, "B"), , , xlWhole)
If Not HCR Is Nothing Then
SBT = HCR.Address
Do
If Range(HCR.Address).Interior.Color = vbGreen Then
SYM = SYM + 1
End If
Set HCR = Range("B5:CF11").FindNext(HCR)
Loop While Not HCR Is Nothing And HCR.Address <> SBT
End If
Cells(STR, "D") = SYM
End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı", vbInformation
End Sub

 

[TİKOS]

Renk Toplama

Hocam
çok teşekkür ederim. Ama çalıştıramadım rica etsem ekteki dosyada gösterebilirmisiniz.

 

[Korhan Ayhan]

Merhaba,

Forumda bununla ilgili hazırlanmış güzel örnekler var. İnceleyiniz...

Renkli zemin ve Font Özelliklerine Göre Uygulamalar
KTF: Renkli Hücreleri Toplama ve Sayma
Renkler ve renk endeksleri ile işlemler
Zemin Rengine Göre Topla Say Sihirbazı
Renk kodları ile işlem yapmak
Renkli hücreyi saydırma

 

[TİKOS]

Korhan hocam teşekkürler
Yanlız benim sıkıntım renk ve hücre içindeki kodları saysın istiyorum.
Ekteki formlarda bulamadım. Yardım rica ediyorum.

 

[Korhan Ayhan]

Merhaba,

Bu linki inceleyiniz.

Desen ve Font renkleri-Sumproduct

 

[TİKOS]

Teşekkürler ama istediğim gibi olmuyor.
Benim Örneğime bakarsanız, IP5 ve Yeşil zeminli olanların kaç adet olduğunu bulmak istiyorum.
Bu doğrultuda yardım edeseniz sevinirim.

 

[Korhan Ayhan]

Merhaba,

Ekli dosyayı inceleyiniz.

Kullanılan kod;

Function RSAY(Alan As Range, Renk As Byte, Kriter As Variant)
    Dim Veri As Range
 
    Application.Volatile True
 
    For Each Veri In Alan
        If Veri.Interior.ColorIndex = Renk Then
            If Veri.Value = Kriter Then
                RSAY = RSAY + 1
            End If
        End If
    Next
End Function

Hücrede kullanım şekli;

=RSAY(Hücre_Aralığı;Renk_Kodu;Sayılacak_Kriter)

 

[TİKOS]

Şahane teşekkürler