renkli toplamada renk sorun oluyor

[EGULERYUZ]

merhabalar üstadların konularından faydalanarak renk toplamı yapabildim fakat koşullu biçimlendirme yapılan hücrelerde renk değişince toplamlar değişmiyor bunu nasıl ayarlayabilirim?Yardımlarınız için şimdididen teşekkürler...

 

[Ömer BARAN]

Merhaba.

Kendinize uyarladığınız kodlar ve kullandığınız koşullu biçimlendirmeler içerisinde ve
çalışır durumda olacak şekilde bir örnek belge ekleyerek soru sormanızda yarar var.
Mantık olarak şunu söyleyeyim, kuvvetle muhtemel kullandığınız kodlar Interior.Color kriterine göre işlem yapıyor.
Ancak; koşullu biçimlendirme ile renklendirilmiş hücrenin boyanması işleminde, hücrenin rengi aslında değişmiyor.

Bu nedenle kullandığınız kodlara koşullu biçimlendirmede kullandığınız KOŞUL'un da dahil edilmesi veya
yeni bir kod oluşturulması gerekecektir diye düşünüyorum.
Sorunuzu yukarıda belirttiğim gibi bir örnek belge ile desteklerseniz, bir üye mutlaka cevaplayacaktır.
.

 

[EGULERYUZ]

ekli dosya

örnek çalışmam ektedir.

 

[EGULERYUZ]

fikri olan yokmu acaba

 

[EGULERYUZ]

ayrıca e --a ve g sutunlarına başka dosyadan veri çekmek istiyorum ama diğer dosyanın c sutununa ericsson yazıldığında bu sutunlara ilgili hücrelerden veri almam gerek bir türlü halledemedim...

 

[okans]

Umarım bu kod işini görür

Function RenkTopla(Alan As Range, RenkliHucre As Range) As Variant
    Dim RenkliAlan As Range
    Dim Sonuc
    Dim Renk
    Application.Volatile
    On Error GoTo Son
    Renk = RenkliHucre.Interior.Color
    For Each RenkliAlan In Alan
        If Renk = RenkliAlan.Interior.Color Then Sonuc = Sonuc + RenkliAlan.Value
    Next
Son:
    RenkTopla = Sonuc
End Function

 

[halit3]

Alternatif kod

Sub renkli_hücreleri_topla()
say1 = 0
say2 = 0
say3 = 0

For i = 2 To Cells(Rows.Count, "e").End(3).Row

If Cells(i, "e").FormatConditions.Count = 1 Then
If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 3 Then
say1 = say1 + CDbl(Cells(i, "e").Value)

End If
If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 6 Then
say2 = say2 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 42 Then
say3 = say3 + CDbl(Cells(i, "e").Value)
End If
End If


If Cells(i, "e").FormatConditions.Count = 2 Then

If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 3 Then
say1 = say1 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(2).Interior.ColorIndex = 3 Then
say1 = say1 + CDbl(Cells(i, "e").Value)
End If

If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 6 Then
say2 = say2 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(2).Interior.ColorIndex = 6 Then
say2 = say2 + CDbl(Cells(i, "e").Value)
End If

If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 42 Then
say3 = say3 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(2).Interior.ColorIndex = 42 Then
say3 = say3 + CDbl(Cells(i, "e").Value)
End If

End If


If Cells(i, "e").FormatConditions.Count = 3 Then

If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 3 Then
say1 = say1 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(2).Interior.ColorIndex = 3 Then
say1 = say1 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(3).Interior.ColorIndex = 3 Then
say1 = say1 + CDbl(Cells(i, "e").Value)
End If

If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 6 Then
say2 = say2 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(2).Interior.ColorIndex = 6 Then
say2 = say2 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(3).Interior.ColorIndex = 6 Then
say2 = say2 + CDbl(Cells(i, "e").Value)
End If

If Cells(i, "e").FormatConditions(1).Interior.ColorIndex = 42 Then
say3 = say3 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(2).Interior.ColorIndex = 42 Then
say3 = say3 + CDbl(Cells(i, "e").Value)
End If
If Cells(i, "e").FormatConditions(3).Interior.ColorIndex = 42 Then
say3 = say3 + CDbl(Cells(i, "e").Value)
End If

End If



Next i
Cells(29, "e").Value = say1
Cells(30, "e").Value = say2
Cells(31, "e").Value = say3
MsgBox "işlem tamam"
End Sub

 

[EGULERYUZ]

sayın okans bu kodu nereye yapıştırırsam çalışır...

 

[Korhan Ayhan]

Kullandığınız kodlar hücrenin fiziksel rengine göre işlem yapar. Fakat siz koşullu biçimlendirme olan hücrelerdeki değerleri renklerine göre toplamak istiyorsunuz.

Bunun için Halit beyin önerdiği kodu kullanabilirsiniz. Ya da alternatif olarak aşağıdaki kodu da deneyebilirsiniz.

Sub RENGE_GÖRE_TOPLA()
    Dim Veri As Range, Toplam As Double, Renk As Byte
    
    Renk = 3
    
    For Each Veri In Range("E2:E20")
        If Veri.DisplayFormat.Interior.ColorIndex = Renk Then
            Toplam = Toplam + Veri.Value
        End If
    Next
    
    Range("F30") = Toplam
End Sub

 

[EGULERYUZ]

............

 

[EGULERYUZ]

ellerinize sağlık hallettim zamanınızı aldım hakkınızı helal edin..birde Korhan Hocam kapalı bir dosyadaki hücreye mesela f1 hücresine ericsson yazılınca a1 hücresindeki tarihin kapalı dosyanın a1 hücresine yazdırılmasını nasıl sağlarım yardımcı olabilirseniz sevinirim...

Kullandığınız kodlar hücrenin fiziksel rengine göre işlem yapar. Fakat siz koşullu biçimlendirme olan hücrelerdeki değerleri renklerine göre toplamak istiyorsunuz.

Bunun için Halit beyin önerdiği kodu kullanabilirsiniz. Ya da alternatif olarak aşağıdaki kodu da deneyebilirsiniz.

Sub RENGE_GÖRE_TOPLA()
    Dim Veri As Range, Toplam As Double, Renk As Byte
    
    Renk = 3
    
    For Each Veri In Range("E2:E20")
        If Veri.DisplayFormat.Interior.ColorIndex = Renk Then
            Toplam = Toplam + Veri.Value
        End If
    Next
    
    Range("F30") = Toplam
End Sub

 

[Korhan Ayhan]

F1 hücresine veri girişi yapacağınız sayfanızın kod bölümüne aşağıdaki kodu uygulayıp deneyiniz.

Kod içindeki tarih yazılacak dosya adını kendinize göre değiştirmeyi unutmayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Uygulama As Object, K1 As Object, S1 As Worksheet, Dosya As String
    
    If Intersect(Target, Range("F1")) Is Nothing Then Exit Sub
    
    If Target = "ericsson" Then
        Application.ScreenUpdating = False
        
        Set Uygulama = CreateObject("Excel.Application")
        Uygulama.Visible = False
        
        Dosya = ThisWorkbook.Path & "\Kitap2.xlsx"
        
        Set K1 = Uygulama.Workbooks.Open(Dosya, False, False)
        Set S1 = K1.Worksheets("Sayfa1")
        
        S1.Range("A1") = CDate(Range("A1"))
        S1.Range("A:A").EntireColumn.AutoFit
        K1.Save
        K1.Close 0
    
        Set S1 = Nothing
        Set K1 = Nothing
        Set Uygulama = Nothing
        
        Application.ScreenUpdating = True
    End If
End Sub

 

[EGULERYUZ]

Korhan hocam verdiğiniz kodla bir türlü halledemedim,dosyaları ekledim bir el atarsanız çok sevinirim,
listelenen dosyadan diğerine aynı mantık ile en son dolu satırdan sonra kayıt edebilirse işim hallolur.şimdididen teşekkürler...

 

[Korhan Ayhan]

Eklediğiniz dosyalarda nasıl bir işlem yapılacak?

Hangi dosyadan hangi dosyaya hangi veri aktarılacak?

 

[EGULERYUZ]

Merhaba Korhan bey
Fatura sıralama dosyasından,ersicsson fatura dosyasına c sutununa ericsson yazıldığında karşılığındaki a sutunundaki tarihin ersicsson fatura dosyasında a sutununun son satırına yazılması yeterli olacak tır. şimdiden teşekkür ederim zaman ayırdığınız için...