aynı verilerin renklenmesi hk

[ijol]

Merhaba,

Diyelimki bir sütünda aynı olanları koyu yada sarı yapmasını istiyorum. fakat her aynı olan verileri başka bir renk olması lazım mesela 5 ler sarı, 4 ler mavi vs. ama bu rakamda olabilir isimde, bu konuda yardımcı olabilirmisiniz?

 

[Ferhat Pazarçevirdi]

Verilerinizin; "A" sütununda, 1.satırdan başlayarak alta doğru devam ettiğini düşünürsek; aşağıdaki kodla benzer olanlar aynı zemin rengi ile işaretlenir.

NOT : Sheet üzerinde; max. 52 adet farklı renk kullanılabilir.

Sub Hucreleri_Renklendirme()
    
    Dim j As Integer
    Dim col As New Collection
    Dim rg As Range
    Dim hcr As Range
    Set rg = Range("A1:A" & Cells(65536, 1).End(xlUp).Row)
    
    On Error Resume Next
    For Each hcr In rg.Cells
        hcr.Interior.ColorIndex = xlNone
        col.Add CStr(hcr), CStr(hcr)
    Next
    On Error GoTo 0
    
    
    For Each hcr In rg.Cells
        For j = 1 To col.Count
            If CStr(hcr) = col.Item(j) Then: Exit For
        Next j
        If j <= 52 Then
            hcr.Interior.ColorIndex = j
        End If
    Next
    
    Set rg = Nothing
 
End Sub

 

[bennidetto]

Selamlar

Değerli üstadım.Konu hakkında bizleri aydınlattığınız için teşekkürler....Fakat benim size şöyle bir sorum olacak.Bir sütuna farklı sayıları ayrı ayrı hücrelere yazarken aynı sayıyı yazdığım ikinci hücrede ikisininde tek renk yapmasını nasıl sağlayabiliriz....

 

[Seyit Tiken]

A sütununa değer girerek deneyiniz.

 

[kulomer46]

Değerli arkadaşım,
yazdığınız makroda aşağıdaki komutlar bana yabancı. ne işe yaradıkları hakkında bilgi yazarsanız sevinirim. Teşekkürler..

Dim col As New Collection

col.Add CStr(hcr), CStr(hcr)

 

[Ferhat Pazarçevirdi]

Selamlar

Değerli üstadım.Konu hakkında bizleri aydınlattığınız için teşekkürler....Fakat benim size şöyle bir sorum olacak.Bir sütuna farklı sayıları ayrı ayrı hücrelere yazarken aynı sayıyı yazdığım ikinci hücrede ikisininde tek renk yapmasını nasıl sağlayabiliriz....

Ekteki örnek dosyayı inceleyiniz. Aşağıdaki kodlar, "Sayfa1"in kod bölümüne yazılmıştır.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim bul As Range
    Dim col As New Collection
    
[COLOR=darkgreen]    'Eğer veri girilen hücre A sütunundaysa[/COLOR]
    If Not Intersect(Target, [A:A]) Is Nothing Then
        
[COLOR=darkgreen]        'Eğer veri girilen hücrenin değeri boşsa;[/COLOR]
        'Yani silme işlemi yapıldıysa
        If Target.Text = Empty Then
            Selection.Interior.ColorIndex = xlNone
            Call Hucreleri_Renklendirme
            Exit Sub
        End If
        
[COLOR=darkgreen]        'Sütunda kullanılan tüm renklerin toplanması[/COLOR]
        On Error Resume Next
        For i = 1 To Cells(65536, 1).End(xlUp).Row
            col.Add CStr(Cells(i, 1).Interior.ColorIndex), CStr(Cells(i, 1).Interior.ColorIndex)
        Next i
        On Error GoTo 0
    
[COLOR=darkgreen]        'Girilen veri, A sütunda aranır[/COLOR]
        Set bul = Columns(1).Find(Target, LookAt:=xlWhole, After:=Range("A65536"), LookIn:=xlValues)
        
[COLOR=darkgreen]        'Girilen veri A sütununda daha önceden varsa ...[/COLOR]
        If Not bul Is Nothing And bul.Address <> Target.Address Then
            Target.Interior.ColorIndex = bul.Interior.ColorIndex
[COLOR=darkgreen]        'Yoksa[/COLOR]
        Else
            If col.Count = 0 Then
                Target.Interior.ColorIndex = 2
            Else
                For j = 2 To 52
                    For i = 1 To col.Count
                        If j = col.Item(i) Then: x = x + 1
                    Next i
                
                    If x = 0 Then
                        Target.Interior.ColorIndex = j
                        Exit For
                    Else
                        x = 0
                        Target.Interior.ColorIndex = xlNone
                        'yani renklendirme yapılamıyor
                    End If
                Next j
           
            End If
        End If
    End If
    Set bul = Nothing
End Sub
[COLOR=darkgreen]'----------------------------------------[/COLOR]
Private Sub Hucreleri_Renklendirme()
    
    Dim j As Integer
    Dim col As New Collection
    Dim rg As Range
    Dim hcr As Range
    Set rg = Range("A1:A" & Cells(65536, 1).End(xlUp).Row)
    
    On Error Resume Next
    For Each hcr In rg.Cells
        hcr.Interior.ColorIndex = xlNone
        col.Add CStr(hcr), CStr(hcr)
    Next
    On Error GoTo 0
    
    
    For Each hcr In rg.Cells
        For j = 1 To col.Count
            If CStr(hcr) = col.Item(j) Then: Exit For
        Next j
        If j < 52 Then
            hcr.Interior.ColorIndex = j + 1
        ElseIf j = 52 Then
            hcr.Interior.ColorIndex = j
        End If
    Next
    
    Set rg = Nothing
 
End Sub

 

[Ferhat Pazarçevirdi]

Değerli arkadaşım,
yazdığınız makroda aşağıdaki komutlar bana yabancı. ne işe yaradıkları hakkında bilgi yazarsanız sevinirim. Teşekkürler..

Dim col As New Collection

col.Add CStr(hcr), CStr(hcr)

Collection nesnesini, bir sepet olarak düşünün. (Baya bildiğiniz sazlardan yapılmış otantik bir sepet, farklı bir anlam çıkarmayın) . Bu sepet öyle bir sepet ki, içine attığınız şeylerin herbirinden sadece bir tane olmalı... Eğer aynı şeyi bir daha atmaya kalkarsanız, kabul etmeyecektir.

Örneğin, sepete bir tane elma koydunuz, sonra armut, sonra portakal vs ... Sonra unuttunuz ve bir elma daha koymaya çalıştınız. Bu durumda, sepet bunu size geri iade edecektir. (Daha doğrusu çalışma kipi hatası üretecek ve kodları durduracaktır)

Collection nesnesi, adından da anlaşılabileceği gibi veri biriktirildiği bir yer ... Dizilerden farkı ise, tek boyutlu olması ve yukarıda anlattığım özelliğe sahip olması ...

Eğer, belirli bir alandaki benzersiz kayıtları, derlemek istiyorsanız; bu metod oldukça kullanışlıdır.

Collection'a veri eklerken; veriyi; koleksiyonda temsil edecek benzersiz bir anahtarla'la (key) ifade etmelisiniz. Aynı anahtar; iki farklı veri için kullanılamaz.

 

[bennidetto]

Ekteki örnek dosyayı inceleyiniz. Aşağıdaki kodlar, "Sayfa1"in kod bölümüne yazılmıştır.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim bul As Range
    Dim col As New Collection
    
[COLOR=darkgreen]    'Eğer veri girilen hücre A sütunundaysa[/COLOR]
    If Not Intersect(Target, [A:A]) Is Nothing Then
        
[COLOR=darkgreen]        'Eğer veri girilen hücrenin değeri boşsa;[/COLOR]
        'Yani silme işlemi yapıldıysa
        If Target.Text = Empty Then
            Selection.Interior.ColorIndex = xlNone
            Call Hucreleri_Renklendirme
            Exit Sub
        End If
        
[COLOR=darkgreen]        'Sütunda kullanılan tüm renklerin toplanması[/COLOR]
        On Error Resume Next
        For i = 1 To Cells(65536, 1).End(xlUp).Row
            col.Add CStr(Cells(i, 1).Interior.ColorIndex), CStr(Cells(i, 1).Interior.ColorIndex)
        Next i
        On Error GoTo 0
    
[COLOR=darkgreen]        'Girilen veri, A sütunda aranır[/COLOR]
        Set bul = Columns(1).Find(Target, LookAt:=xlWhole, After:=Range("A65536"), LookIn:=xlValues)
        
[COLOR=darkgreen]        'Girilen veri A sütununda daha önceden varsa ...[/COLOR]
        If Not bul Is Nothing And bul.Address <> Target.Address Then
            Target.Interior.ColorIndex = bul.Interior.ColorIndex
[COLOR=darkgreen]        'Yoksa[/COLOR]
        Else
            If col.Count = 0 Then
                Target.Interior.ColorIndex = 2
            Else
                For j = 2 To 52
                    For i = 1 To col.Count
                        If j = col.Item(i) Then: x = x + 1
                    Next i
                
                    If x = 0 Then
                        Target.Interior.ColorIndex = j
                        Exit For
                    Else
                        x = 0
                        Target.Interior.ColorIndex = xlNone
                        'yani renklendirme yapılamıyor
                    End If
                Next j
           
            End If
        End If
    End If
    Set bul = Nothing
End Sub
[COLOR=darkgreen]'----------------------------------------[/COLOR]
Private Sub Hucreleri_Renklendirme()
    
    Dim j As Integer
    Dim col As New Collection
    Dim rg As Range
    Dim hcr As Range
    Set rg = Range("A1:A" & Cells(65536, 1).End(xlUp).Row)
    
    On Error Resume Next
    For Each hcr In rg.Cells
        hcr.Interior.ColorIndex = xlNone
        col.Add CStr(hcr), CStr(hcr)
    Next
    On Error GoTo 0
    
    
    For Each hcr In rg.Cells
        For j = 1 To col.Count
            If CStr(hcr) = col.Item(j) Then: Exit For
        Next j
        If j < 52 Then
            hcr.Interior.ColorIndex = j + 1
        ElseIf j = 52 Then
            hcr.Interior.ColorIndex = j
        End If
    Next
    
    Set rg = Nothing
 
End Sub

fakat girmiş olduğum değerlerin hepsi renkleniyor...Bir değer girsem farklı renk alıyor...Dolayısıyla benim için karmaşıklığa yol açıyor...Sadece girilen iki veya daha fazla aynı değerin renkenmesini nasıl yapabiliriz....
Saygılarımla...
İyi çalışmalar...

 

[bennidetto]

Değerli üstatlarım desteklerinizi bekliyorum....
Saygılarımla

 

[salem]

Konuya ben de baska bir sekilde sorarak katilabilir miyim? Bende excel sayfama girmis oldugum sayilarin oldugu hucrenin deger araligina gore renklenmesini istiyorum, bunu nasil yapabilirim? Makro kullanmadan bunu eger(if) komutu icine '' gecti" yaziliyordu ve hucreye geliyordu ama ben yazi yazmak yerine renk atamak istiyorum nasil yapabilirim?

ornek;

hucre degeri 0 ile 50 arasinda ise hucre dolgusu sari olsun
hucre degeri 51 ile 100 arasinda ise hucre dolgusu kirmizi olsun misal olarak.

bunu if (eger komutu) ile soyle yapiyorduk:
hucre degeri 0 ile 50 arasinda ise gecti yaz ya da bos birak
huvre degeri 51 ile 100 arasinda ise kaldi yaz ya da bos birak

Yardimlarnizi bekliyorum. Makro kodu gonderirseniz yanina aciklama da eklerseniz sevinirim. Ama bunu eger komutu ile yapamaz miyiz?

Tesekkurler. Saygilar.

 

[ibrahim_44]

bennidetto kardeş bir örnek hazırlamaya çalıştım ama inşallah işini görür.
benim yapmaya çalıştığım şey şu;
renklendirmek istediğiniz sayıları kendiniz belirliyorsunuz siz bir şey belirtmediğiniz için 5 ayrı sayıyı farklı renklere boyayacak şekilde ayarladım. bunu arttırabiliriz isterseniz b2 den b6 ya kadar olan 5 hücreye a stünunda renklendirmek istediğiniz rakamları yazın o rakamların yanındaki renkler o sayıyı hangi renge boyayacağını gösteriyor yine aynı sayfada verdiğim renk indexide excelin renklerinin kodlarını göstermekte sayfa1'in kod bölümüne giderek kodlara bakabilrsiniz inşallah size bir fikir verebilir.

 

[kulomer46]

Değerli arkadaşım Ferhat Pazarçevirdi'ye Collection nesnesi hakkında verdiği bilgiler için teşekkür ediyorum. Verdiğiniz bilgiler çok yararlı oldu.

 

[bennidetto]

İbrahim paylaştığın bilgi için teşekkür ederim....İnce bi fikir oldu benim için...Biraz geliştirerek başardım sonunda.....

Saygılarımla
İyi çalışmalar...

 

[mavisim_03220]

guzellllllllllllllllllllllllllll

 

[karakeder]

MERHABALAR KENDİM DENEM YAPTIM AMA TÜM SATIRI RENKLENDİREMEDİM. MAKRO DOSYASI AŞAĞIDAKİ GİBİ. EKTE DOSYA MEVCUT

Sub Hucreleri_Renklendirme()

Dim j As Integer
Dim col As New Collection
Dim rg As Range
Dim hcr As Range
Set rg = Range("B2:B" & Cells(680, 1).End(xlUp).Row)

On Error Resume Next
For Each hcr In rg.Cells
hcr.Interior.ColorIndex = xlNone
col.Add CStr(hcr), CStr(hcr)
Next
On Error GoTo 0


For Each hcr In rg.Cells
For j = 1 To col.Count
If CStr(hcr) = col.Item(j) Then: Exit For
Next j
If j <= 52 Then
hcr.Interior.ColorIndex = j
End If
Next

Set rg = Nothing

End Sub