hücrelerin koşullu renklendirmesi

[kardelen1611]

arkadaşlar kolay gelsin ekte gönderdigim dosyda sıralama yapılan hücrelerin sıralanışına göre renklendirmesini yapmak istiyorum yardımcı olursanız çok sevinirim hepinize kolay gelsin.b1 ve b13 hücreleri arasında a1 ve a2 hücreleri arasındaki sayıların büyükten küçüge sıralanmasının renklendirilmesini nasıl yapabilirim.

 

[Korhan Ayhan]

Selamlar,

Ben sorunuzu defalarca okudum fakat anlayamadım. Örnek dosyanızın içine olması gereken sonucuda ekleyip tekrar yollarmısınız.

 

[kardelen1611]

evet fark ettim çok özür dilerim yanlış dosyayı göndermişim ekteki dosyayı incelerseniz sevinirim.b1 ve b13 hücreleri arasında a1 ve a13 hücreleri arasındaki sayıların büyükten küçüge sıralanmasının renklendirilmesini nasıl yapabilirim.a13 ten sonrada sayılar yazacagım b13 ten sonrada sıralanacak aynızamandada renklendirme olsun istiyorum

 

[Ali]

Rank formülü benzersiz veri varsa sağlıklı çalışır yoksa hatalı sonuç alırsınız.
Aşağıdaki linki inceleyiniz.

Girilen sayısal değere göre hücre renklendirme

.

 

[kardelen1611]

mehaba kolay gelsin linki tıklıyorum sayfa açılıyor ama açılan sayfadaki ek açıl mıyor

 

[kardelen1611]

merhaba kolay gelsin dosyayı degiştirdim incelermisiniz

 

[Ali]

O linkteki 20 nolu mesajda Levent Bey'in makrosunu deneyiniz.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu ilgili sayfanın kod bölümüne uygulayıp denermisiniz. Eski kodunuzu silerek uygulayın.

Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim X As Long, BÜYÜK As Byte, BUL As Range, ADRES As String
    
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    
    Target.Offset(0, 2) = Now
    
    Range("A:A").Interior.ColorIndex = xlNone
    
    On Error Resume Next
    For X = 1 To 5
    BÜYÜK = WorksheetFunction.Large(Range("B:B"), X)
    Set BUL = Range("B:B").Find(BÜYÜK, LookIn:=xlValues, LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    ADRES = BUL.Address
    Do
        Select Case X
            Case Is = 1
            Cells(BUL.Row, 1).Interior.ColorIndex = 15
            Case Is = 2
            Cells(BUL.Row, 1).Interior.ColorIndex = 8
            Case Is = 3
            Cells(BUL.Row, 1).Interior.ColorIndex = 6
            Case Is = 4
            Cells(BUL.Row, 1).Interior.ColorIndex = 3
            Case Is = 5
            Cells(BUL.Row, 1).Interior.ColorIndex = 4
        End Select
    Set BUL = Range("B:B").FindNext(BUL)
    Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    Next
End Sub

 

[kardelen1611]

merhaba gönderinizi kopyaladım ilgili sayfayı açtım ve kod bölümüne yapıştırdım ama bundan sonra ne yapacagımı bilemiyorum.Sayfa 2 bunu uygulaya bilirmisinz

 

[Korhan Ayhan]

Selamlar,

Kodu sayfanın Change olayına uyguladım. Yani siz A sütununa yeni bir değer girdiğinizde yada A sütununda bir hücre içine girip çıktığınızda çalışacaktır.

 

[kardelen1611]

merhaba sizi fazlameşgulettim kusurabakmayın ben bir dosyayı ekliyorum kodu uygularsanız sevinirim kolay gelsin

 

[Korhan Ayhan]

Selamlar,

En son eklediğiniz dosyada hangi sütun renklenecek çözemedim. Dosyanızda detayları anlatırsanız yardımcı olabiliriz.

 

[kardelen1611]

merhaba kolaygelsin h sütunundan başlayarak aı sütununa kadar olan kolanlar c deki verilere göre ayrı ayrı sıralanmış durumda yani h sütunuu c deki son 3 günün sıralaması.ı sütunuu c deki son dört günün büyükten küçüge göre sıralanması.j sütunu ise c deki son beş günün büyükten küçüge dogru sıralanması.k sütunu c deki son altı günün büyükten küçüge dogru sıralanması... gibi devam ediyor aı sütununa kadar bir artarak.benim sizden istedigim ise büyükten küçüge dogru yapılan sıralamanın renklendirilmesi yani h sütununda 1 kırmızı 2 sarı 3 yok çünkü 2 adet aynı rakam var.yani burdaki mantıgım şu son 3 gün içerisinde girdigim sayıları sıraladım,son dörtgün içerisindeki girdigim sayıları sıraladım,son beş gün içerisindeki girdigim sayıları sıraladım...son otuzgün içerisinde girdigim sayıları sıraladım ama bunların renklendirmesini yapmak istiyorum.mesela son yirmi gün içerisindeki sayıların en büyügü 1 sayısı bu kırmızı olsun 2 sarı 3 yeşil 4 mavi 5 portakal... renginde olsun istiyorum

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz. H45:AI74 hücre aralığında herhangi bir hücreyi mouse ile tıkladığınızda kod renkleri yenileyecektir. Eğer bu hücre kısıtlamasını kaldırmak isterseniz aşağıdaki koddaki kırmızı renkli bölümü silin yada başına tek tırnak işareti ekleyerek pasif yapın.

Kullanılan kod;

Option Explicit
 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim X As Long, Y As Byte, BUL As Range, ADRES As String
 
    [COLOR=red]If Intersect(Target, [H45:AI74]) Is Nothing Then Exit Sub[/COLOR]
    If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
    If Target.Count > 1 Then Exit Sub
 
    Application.ScreenUpdating = False
    Range("H45:AI74").Interior.ColorIndex = xlNone
 
    On Error Resume Next
 
    For X = 8 To 35
        For Y = 1 To 5
            Set BUL = Range(Cells(45, X), Cells(74, X)).Find(Y, LookIn:=xlValues, LookAt:=xlWhole)
            If Not BUL Is Nothing Then
            ADRES = BUL.Address
            Do
                If Y = 1 Then
                    Cells(BUL.Row, X).Interior.ColorIndex = 15
                ElseIf Y = 2 Then
                    Cells(BUL.Row, X).Interior.ColorIndex = 8
                ElseIf Y = 3 Then
                    Cells(BUL.Row, X).Interior.ColorIndex = 6
                ElseIf Y = 4 Then
                    Cells(BUL.Row, X).Interior.ColorIndex = 3
                ElseIf Y = 5 Then
                    Cells(BUL.Row, X).Interior.ColorIndex = 4
                End If
            Set BUL = Range(Cells(45, X), Cells(74, X)).FindNext(BUL)
            Loop While Not BUL Is Nothing And BUL.Address <> ADRES
            End If
        Next
    Next
    Application.ScreenUpdating = True
End Sub

 

[kardelen1611]

çok çok teşekkür ederim ilginize elinize saglık...