koşula göre renkli hücreleri saydırma fonksiyonu

[kadirdiloglu]

Merhaba,

ekteki dosyamda hücre renklerini sayan bir makro var. Ama ben bunu başka bir koşula bağlı olarak saydırmak istiyorum. Detaylar dosyanın içindedir.Yardımcı olur musunuz?


http://s9.dosya.tc/server/xnsni9/Puantaj_sorun.zip.html

 

[Necdet]

Merhaba,

Dosyanın içinde herhangi bir açıklama göremedim. Böyle yardım almanız zor hem de pek zor.

Ayrıca milletin dosyayı indirmeden açıklayıcı bilgi verirseniz, ilgi duyan arkadaşlar dosyanızı inceleyerek yardımcı olabilirler.

 

[kadirdiloglu]

Merhaba,

Dosyanın içinde herhangi bir açıklama göremedim. Böyle yardım almanız zor hem de pek zor.

Ayrıca milletin dosyayı indirmeden açıklayıcı bilgi verirseniz, ilgi duyan arkadaşlar dosyanızı inceleyerek yardımcı olabilirler.

dosyanın alt kısmında sorum açıkça yazıyor ama;

d6:d444 hücreleri arasında hücre renklerini sayan =DRSay($D$2;D6445) böyle bir formülüm var. benim yapmak istediğim.b6:b444 hücrelerinde yazan "D" yada "E" harflerine göre d6:d444 hücreleri içindeki renkleri ayrı ayrı saysın

yani "d" olup rengi kırımızı olan "E"olup rengi kırımız olan

 

[Korhan Ayhan]

Aşağıdaki fonksiyonu kullanabilirsiniz.

Eklediğiniz dosyada D452 hücresinde aşağıdaki gibi kullanabilirsiniz.

=RENK_SAY($D$6:$D$444;$L$2;$B$6:$B$444;"D")

Diğer hücreleri kendiniz ayarlarsınız.

Option Explicit

Function RENK_SAY(Alan1 As Range, Renk As Range, Alan2 As Range, Kriter2)
    Dim WF As WorksheetFunction, X As Long, Say As Long
    Dim Veri As Range, Dizi1 As Variant, Dizi2 As Variant
    
    Application.Volatile True
    
    Set WF = Application.WorksheetFunction
    
    Dizi1 = WF.Transpose(Alan1)
    
    For Each Veri In Alan1
        Say = Say + 1
        If Veri.Interior.ColorIndex = Renk.Interior.ColorIndex Then
            Dizi1(Say) = 1
        Else
            Dizi1(Say) = 0
        End If
    Next
    
    Dizi2 = WF.Transpose(Alan2)
    
    For X = 1 To UBound(Dizi2)
        If UCase(Replace(Replace(Dizi2(X), "ı", "I"), "i", "İ")) = UCase(Replace(Replace(Kriter2, "ı", "I"), "i", "İ")) Then
            Dizi2(X) = 1
        Else
            Dizi2(X) = 0
        End If
    Next
    
    RENK_SAY = WF.SumProduct(Dizi1, Dizi2)
End Function

 

[kadirdiloglu]

Aşağıdaki fonksiyonu kullanabilirsiniz.

Eklediğiniz dosyada D452 hücresinde aşağıdaki gibi kullanabilirsiniz.

=RENK_SAY($D$6:$D$444;$L$2;$B$6:$B$444;"D")

Diğer hücreleri kendiniz ayarlarsınız.

Option Explicit

Function RENK_SAY(Alan1 As Range, Renk As Range, Alan2 As Range, Kriter2)
    Dim WF As WorksheetFunction, X As Long, Say As Long
    Dim Veri As Range, Dizi1 As Variant, Dizi2 As Variant
    
    Application.Volatile True
    
    Set WF = Application.WorksheetFunction
    
    Dizi1 = WF.Transpose(Alan1)
    
    For Each Veri In Alan1
        Say = Say + 1
        If Veri.Interior.ColorIndex = Renk.Interior.ColorIndex Then
            Dizi1(Say) = 1
        Else
            Dizi1(Say) = 0
        End If
    Next
    
    Dizi2 = WF.Transpose(Alan2)
    
    For X = 1 To UBound(Dizi2)
        If UCase(Replace(Replace(Dizi2(X), "ı", "I"), "i", "İ")) = UCase(Replace(Replace(Kriter2, "ı", "I"), "i", "İ")) Then
            Dizi2(X) = 1
        Else
            Dizi2(X) = 0
        End If
    Next
    
    RENK_SAY = WF.SumProduct(Dizi1, Dizi2)
End Function

Çok teşekkürler tam aradığım makro