renkli hücre içindekileri toplama

[kadirdiloglu]

Merhaba,

Sütun içindeki renkli hücrelerin içindeki verileri toplamak istiyorum. Nasıl yapabilirim?

Renkli hücreleri saydırmak için aşağıdaki makroyu kullanıyorum. ama içindeki sayıları toplamak için ne yapmalıyım?

Örnek dosya ; http://s2.dosya.tc/server/29hpzp/deneme7.zip.html

Function DRSay(rhcr As Range, alns As Range)
Application.Volatile
Dim sut As Integer
Dim Thcr As Range
sut = rhcr.Interior.ColorIndex
For Each Thcr In alns
    If sut = Thcr.Interior.ColorIndex Then
        DRSay = DRSay + 1
    End If
Next Thcr
End Function

 

[Muzaffer Ali]

Function DRSay(rhcr As Range, alns As Range)
Application.Volatile
Dim sut As Integer
Dim Thcr As Range
[COLOR="red"]dim Toplam as double[/COLOR]
sut = rhcr.Interior.ColorIndex
For Each Thcr In alns
    If sut = Thcr.Interior.ColorIndex Then
        DRSay = DRSay + 1
        [COLOR="Red"]toplam=toplam + thcr [/COLOR]
    End If
Next Thcr
End Function

 

[kadirdiloglu]

Function DRSay(rhcr As Range, alns As Range)
Application.Volatile
Dim sut As Integer
Dim Thcr As Range
[COLOR="red"]dim Toplam as double[/COLOR]
sut = rhcr.Interior.ColorIndex
For Each Thcr In alns
    If sut = Thcr.Interior.ColorIndex Then
        DRSay = DRSay + 1
        [COLOR="Red"]toplam=toplam + thcr [/COLOR]
    End If
Next Thcr
End Function

Bu makro da yukarıdaki sonucun aynısını veriyor yani sadece renkli hücreyi sayıyor

 

[Muzaffer Ali]

[COLOR="red"]dim Toplam as double[/COLOR]
Function DRSay(rhcr As Range, alns As Range)
Application.Volatile
Dim sut As Integer
Dim Thcr As Range
sut = rhcr.Interior.ColorIndex
For Each Thcr In alns
    If sut = Thcr.Interior.ColorIndex Then
        DRSay = DRSay + 1
        [COLOR="Red"]toplam=toplam + thcr [/COLOR]
    End If
Next Thcr
End Function

şimdi "Toplam" değişkeninden toplam bilgisini alabilirsiniz.

Örnek:
msgbox toplam

Eğer yine yapamazsanız dosyanızı ekleyin üzerinde düzenleme yapayım.

 

[Muzaffer Ali]

Module1 deki kodları silin aşağıdakileri kopyalayıp yapıştırın.

Function DRSay(rhcr As Range, alns As Range)
    Application.Volatile
    Dim sut As Integer
    Dim Thcr As Range
    sut = rhcr.Interior.ColorIndex
    For Each Thcr In alns
        If sut = Thcr.Interior.ColorIndex Then
            DRSay = DRSay + 1
        End If
    Next Thcr
End Function

Function DRTopla(rhcr As Range, alns As Range)
    Application.Volatile
    Dim sut As Integer
    Dim Thcr As Range
    sut = rhcr.Interior.ColorIndex
    For Each Thcr In alns
        If sut = Thcr.Interior.ColorIndex Then
            DRTopla = DRTopla + Thcr
        End If
    Next Thcr
End Function

Toplama yapmak için =DRTopla fonksiyonunu kullanın.

 

[kadirdiloglu]

Module1 deki kodları silin aşağıdakileri kopyalayıp yapıştırın.

Function DRSay(rhcr As Range, alns As Range)
    Application.Volatile
    Dim sut As Integer
    Dim Thcr As Range
    sut = rhcr.Interior.ColorIndex
    For Each Thcr In alns
        If sut = Thcr.Interior.ColorIndex Then
            DRSay = DRSay + 1
        End If
    Next Thcr
End Function

Function DRTopla(rhcr As Range, alns As Range)
    Application.Volatile
    Dim sut As Integer
    Dim Thcr As Range
    sut = rhcr.Interior.ColorIndex
    For Each Thcr In alns
        If sut = Thcr.Interior.ColorIndex Then
            DRTopla = DRTopla + Thcr
        End If
    Next Thcr
End Function

Toplama yapmak için =DRTopla fonksiyonunu kullanın.

teşekkürler işe yaradı..

 

[bonoparte]

Merhaba,

Formül koşullu biçimlerde ile yapılan hücre renklendirmelerinde çalışmıyor. Nasıl bir değişiklik yapılabilir, yardımcı olabilirmisiniz.

 

[Korhan Ayhan]

Koşullu biçimlendirme renklerini fonksiyonla saydıramazsınız. Bunun yerine genellikle koşullarınızı farklı formülere entegre edip saydırma ya da toplama işlevlerini tavsiye ediyoruz. Bunun dışında düz makro ile koşullu biçimlendirilmiş hücrelerin rengini saydırabilirsiniz.

Koşullu biçimlenmiş alanı seçip kodu çalıştırın. Kod kırmızı dolgu rengi olan hücreleri sayar.

Sub RENK_SAY()
    Dim Veri As Range
    For Each Veri In Selection
        If Veri.DisplayFormat.Interior.ColorIndex = 3 Then Say = Say + 1
    Next
    Range("C1") = Say
End Sub