Hücredeki verileri kod ile renklendirme ve sayısını alma.

[Bora K]

Merhabalar

Belirli bir alanda ki (D4:M33)
Verileri kod ile renklendirip
daha sonrada sütunun altına hangisinden
kaç adettir toplamlarını almak istemekteyim.

Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[Bora K]

Güncel konu.

 

[Ömer]

Merhaba,

Renklendirme anladım sanırım fakat saymadaki mantığı anlayamadım. Örneğin, kırmızı bölümde neden bir satır boyunca sadece armut yazdınız.

Bu bölümü detaylı açıklarmısınız.

 

[Bora K]

Merhabalar
Ömer Hocam.

Alakanız için çok teşekkür ederim.
Çok haklısınız. Görüntüde hoş olmamış.
Armut
Elma
Erik
Kayısı
……….

diye O36 dan itibaren aşağı doğru
sıralanırsa daha estetik olur.

 

[Ömer]

Eki inceleyiniz. Tabloyu bu şekilde kullanmanız daha pratik olur sanırım.
A sütunundaki ölçütleri D4:M33 aralığında arar ölçütün renki neyse bulduğuna onun rengini verir ve sayar.

Umarım doğru anlamışımdır.

Not: Son eklediğiniz dosyayı mesajımdan sonra gördüm, siz sayma işlemini sütun sütun yapmak istiyorsunuz sanırım? Aynı mantıkla yapabilirsiniz. Dosyanıza uyarlayamazsanız bildirin ben düzenlerim.

.

 

[Bora K]

Evet söylediğiniz gibi Enver Hocam.
Saydırmayı sütun sütun yapacağız.

Adres değişimi olsaydı olurdu da sanırım bunun üstesinden gelemem.
Müsait anınızda ilgilenirseniz çok sevinirm.

 

[Ömer]

Bu şekilde deneyin. Yalnız N36 dan sonra yazdığınız ölçütlerin rengini istediğiniz renk fontu neyse o şekilde renklendiriniz. (O10:O14 aralığında renklendirdiğiniz gibi.) Eğer sabit olacaksa renk kodlarını kodlarada ilave edebiliriz.

Sub Renklendir_Say()
    
    Dim i As Long, c As Range, Adr As String, Renk As Byte, say As Long, j As Byte
    
    Application.ScreenUpdating = False
    
    Range("D36:M" & Rows.Count).ClearContents
    Range("D4:M33").Font.ColorIndex = 0
    For i = 36 To Cells(Rows.Count, "N").End(xlUp).Row
        Renk = Cells(i, "N").Font.ColorIndex
        For j = 4 To 13
            say = 0
            With Range(Cells(4, j), Cells(33, j))
                Set c = .Find(Cells(i, "N"), LookIn:=xlValues, LookAt:=xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        c.Font.ColorIndex = Renk
                        say = say + 1
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            End With
            Cells(i, j) = say
        Next j
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[Bora K]

Merhabalar Ömer Hocam.
Kod gayet hoş oldu.
Ellerinize sağlık.

Renk olayını bu şekilde kodlamanız daha bir işlevsel yaptı kodu.
Hatta bu şekilde olması bir fikir getirdi aklıma şayet mümkünatı var ise
Yapabilirseniz çok daha iyi olur. OLmaz ise canımız sağolsun.

Olabiliritesi varsa şunu istiyorum;
Armut
Elma
Erik
Kayısı
verileri N36:N40 aralığında. Bu aralık (AA4:AA8) e çekilirse çok daha süper olacak
benim açımdan. Tuhaf oldu diyeceksin belki ama olursa iyi olur.
Toplam alınan rakamlar yine aynı yerinde kalacak. (D36:M40)

 

[Ömer]

Sayma aralığı aynı mı kalacak?

 

[Bora K]

Evet sayılar eski yerinde olacak.

 

[Ömer]

Bu şekilde deneyin.

Sub Renklendir_Say()
    
    Dim i As Long, c As Range, Adr As String, Renk As Long
    Dim say As Long, j As Byte, sat As Long
    
    Application.ScreenUpdating = False
    
    Range("D36:M" & Rows.Count).ClearContents
    Range("D4:M33").Font.ColorIndex = 0
    sat = 36
    For i = 4 To Cells(Rows.Count, "AA").End(xlUp).Row
        Renk = Cells(i, "AA").Font.ColorIndex
        For j = 4 To 13
            say = 0
            With Range(Cells(4, j), Cells(33, j))
                Set c = .Find(Cells(i, "AA"), LookIn:=xlValues, LookAt:=xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        c.Font.ColorIndex = Renk
                        say = say + 1
                        Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            End With
            Cells(sat, j) = say
        Next j
        sat = sat + 1
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

.

 

[Bora K]

Harika oldu.

Ömer Hocam ellerinize sağlık.
Herşey gönlüzce olsun inşallah.
Saygılar.