Koşullu Biçimlendirme renklerini saydırma

[Feylosof]

Merhaba

Sub kirmizi()
Dim say As Integer
For sat = 4 To 42
For sut = 3 To 6
If Cells(sat, sut).Interior.Color = 255 And Cells(sat, sut).Value = "X" Then

say = say + 1
End If
Next
Next
Range("C43") = say

End Sub

Bu kod koşullu biçimlendirme ile boyanan hücreleri saymıyor. Bunu nasıl düzeltebiliriz. Teşekkür ederim

 

[Ömer]

Merhaba,

Örnek dosya ekler misiniz.

 

[ÖmerFaruk]

Eğer saydırdığınız alanın tamamı aynı koşullu biçimlendirmeye sahipse, ilk IF satırını silebilirsiniz.

Sub kirmizi()
Dim say As Integer
    Range("A1").Interior.Color = 255
    For sat = 4 To 7
        For sut = 1 To 2
        If Cells(sat, sut).FormatConditions.Count = 0 Then GoTo Devam
        If Cells(sat, sut).FormatConditions(1).Interior.Color = 255 And Cells(sat, sut).Value = "X" Then
            say = say + 1
        End If
Devam:
        Next
    Next
    Range("C3") = say
End Sub

 

[Feylosof]

Sayın @Ömer ; Sayın @NextLevel çok teşekkür ederim. Yoğunluktan dolayı dosya yükleyemedim. Kusuruma bakmayın lütfen. Dosya ektedir.
NextLevel üstadım sizin kodunuzu çalıştıramadım.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Kosullu_Bicimlendirme_Renklerini_Say()
    Dim Veri As Range, X As Integer, Say As Integer, Sutun As Integer
    Dim Kirmizi_Say As Integer, Sari_Say As Integer, Mavi_Say As Integer
   
    Sutun = 3
   
    For X = 0 To 4
        For Each Veri In Range("C4:F42").Offset(, X * 4)
            Select Case Veri.DisplayFormat.Interior.ColorIndex
                Case 3: Kirmizi_Say = Kirmizi_Say + 1
                Case 6: Sari_Say = Sari_Say + 1
                Case 23: Mavi_Say = Mavi_Say + 1
            End Select
        Next
       
        Cells(43, Sutun) = Kirmizi_Say
        Cells(44, Sutun) = Sari_Say
        Cells(45, Sutun) = Mavi_Say
        Kirmizi_Say = 0
        Sari_Say = 0
        Mavi_Say = 0
        Sutun = Sutun + 4
    Next
   
    MsgBox "Renk sayma işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Feylosof]

Değerli üstadım @Korhan Ayhan hocam çok teşekkür ederim. Elinize emeğinize sağlık.

 

[Ömer]

Formül kullanarak alternatif:

C43 hücresine yazıp yana ve alt hücrelere kopyalayın.

=TOPLA.ÇARPIM(($B$4:$B$42=$B43)*(C$4:F$42="x"))

 

[Feylosof]

Formül kullanarak alternatif:

C43 hücresine yazıp yana ve alt hücrelere kopyalayın.

=TOPLA.ÇARPIM(($B$4:$B$42=$B43)*(C$4:F$42="x"))

@Ömer hocam teşekkür ederim.