2 degişkenli sütunda renge göre toplama

[mahmyt]

üstadlar merhaba;
benim sıkıntım 1.sütunda bulunan dolar yada euro ifadesine göre 2.sütundaki değerleri toplamak yani yeşil renge boyalı eurolar ne kadar sarı renke boyalı dolarlar ne kadar
gibi ancak ben internetten buldugum makro ile yaptıgım işlem de sadece renklerin toplamı ne kadar işlemini bulmaktayım. toplam işlemini dolar yada euro diye nasıl formüle edebilirim saygılarımla

exceli umarım doğru şekilde paylaşmışımdır.
toplama renge göre

 

[ÖmerFaruk]

Dosya ekiniz açılmıyor.

 

[mahmyt]

renk üstad umarım bu şekildedir.

 

[ÖmerFaruk]

Verdiğiniz örnek tabloya göre

Euro için
=ETOPLA(D:D;H7;E:E)

Dolar için
=ETOPLA(D:D;H8;E:E)

DD ve EE aralıklarını gerçek dosyanıza göre daha kısa bir aralık yapabilirsiniz.
Renklendirmeyi dikkate almadım.

 

[mahmyt]

hocam bana renklendirmeye göre toplam lazım önemli olan şu ki çek ödemesi için kullanıcam ödedikce sarı yeşile dönecek

 

[mahmyt]

Function Renklere_Gore_Degerleri_Topla(bolge As Range, hangi_renk As Range) As Double
Renklere_Gore_Degerleri_Topla = 0
Dim Cell
Color_Index = hangi_renk.Interior.ColorIndex
For Each Cell In bolge
If (Cell.Interior.ColorIndex = Color_Index) And IsNumeric(Cell.Value) Then
Renklere_Gore_Degerleri_Topla = Renklere_Gore_Degerleri_Topla + Cell.Value
End If
Next Cell
End Function

böyle bir makro var ancak bu sadece renge göre işlem yapıyor eur ve doları sütununu eklemek mümkün müdür

 

[ÖmerFaruk]

Hem Renk hem de Kur sorgulanıyor.

Function Renklere_Gore_Degerleri_Topla(bolge As Range, hangi_renk As Range) As Double
    Renklere_Gore_Degerleri_Topla = 0
    Dim Cell
    Color_Index = hangi_renk.Interior.ColorIndex
    For Each Cell In bolge
        If (Cell.Interior.ColorIndex = Color_Index) And IsNumeric(Cell.Value) And Cell.Offset(, -1).Value = hangi_renk.Value Then
            Renklere_Gore_Degerleri_Topla = Renklere_Gore_Degerleri_Topla + Cell.Value
        End If
    Next Cell
End Function

 

[mahmyt]

Hem Renk hem de Kur sorgulanıyor.

Function Renklere_Gore_Degerleri_Topla(bolge As Range, hangi_renk As Range) As Double
    Renklere_Gore_Degerleri_Topla = 0
    Dim Cell
    Color_Index = hangi_renk.Interior.ColorIndex
    For Each Cell In bolge
        If (Cell.Interior.ColorIndex = Color_Index) And IsNumeric(Cell.Value) And Cell.Offset(, -1).Value = hangi_renk.Value Then
            Renklere_Gore_Degerleri_Topla = Renklere_Gore_Degerleri_Topla + Cell.Value
        End If
    Next Cell
End Function

üstad bunu formüle ederken =Renklere_Gore_Degerleri_Topla(D6:H10;H7) bu şekilde olmayacak mı

 

[ÖmerFaruk]

I7 ye yazarken
=Renklere_Gore_Degerleri_Topla(E6:E10;H7)

I8 için
=Renklere_Gore_Degerleri_Topla(E6:E10;H8)

 

[mahmyt]

renk üstad formülde yine döviz cinsi dikkate alamadan toplamaktadır.

 

[ÖmerFaruk]

Ben deniyorum ve doğru işlem yapıyor.

 

[mahmyt]

Ben deniyorum ve doğru işlem yapıyor.

exceli paylaştım da nerede hata yaptıgımı söyleyebilir misin

 

[Korhan Ayhan]

Alternatif;

Kullanım şekli;

=R_TOPLA(Toplanacak_Alan;Koşul_Alanı;Koşul;Renk_Kodu)

Paylaştığınız dosyada I7 hücresi için aşağıdaki gibi uygulayıp deneyiniz.

=R_TOPLA($E$6:$E$10;$D$6:$D$10;H7;H7)

Option Explicit

Function R_TOPLA(Toplanacak_Alan As Range, Koşul_Alanı As Range, _
                 Koşul As Variant, Renk_kodu As Variant) As Double
    Dim Veri As Range, Say As Long
    
    Application.Volatile True
    
    For Each Veri In Koşul_Alanı
        Say = Say + 1
        If Veri.Value = Koşul.Value Then
            If Veri.Interior.ColorIndex = Renk_kodu.Interior.ColorIndex Then
                R_TOPLA = R_TOPLA + Toplanacak_Alan.Cells(Say).Value
            End If
        End If
    Next
End Function

 

[mahmyt]

next level üstadım gönderdiğiniz makro var olan renklere göre topla makrosu varken başka bir makro sayfasına yapıştırmışım emekleriniz ve zaman ayırdığınız için teşekkür ederim.
koray ayhan üstadım emeğinize ve zamanınıza sağlık teşekkür ederim.