Hücredeki memurun derece/kademesine göre satırları renklendirme

[Kemter]

Merhaba arkadaşlar,
Ek dosyada maaş parametresinde memur derece/kademesine var burada yapmak istediğim
KH Der.Kad.
C
8- > 7-
7- > 6-
6- > 5-
5- > 4-
4- > 3-
3- > 2-
2- > 1-
C sütunundaki değerleri yukarıdaki değerlere göre satırları bulup renklendirsin istiyorum.
Saygılarımla.

Sicil No	Ad Soyad	KH Der.Kad.	EM Der.Kad.	Kıdem	Y.Dil Tazminatı
		3-2 > 2-1	3-2 > 2-1
		3-3 > 2-2	3-3 > 2-2
		4-3 > 3-1	4-3 > 3-1
		5-3 > 4-1	5-3 > 4-1
		8-3 > 7-1	8-3 > 7-1
		2-3 > 1-1	8-3 > 7-1
		6-1 > 5-1	8-3 > 7-1
		7-3 > 6-1	7-3 > 6-1

 

[pitchoute]

Merhaba, makro olarak şu makroyu dener misiniz? Yedek almayı unutmayın lütfen;

Sub SatirlariRenklendir()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim sonSatir As Long
    sonSatir = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    Dim renkler As Object
    Set renkler = CreateObject("Scripting.Dictionary")
    
    renkler.Add "1-1", RGB(255, 200, 200)
    renkler.Add "2-1", RGB(255, 230, 180)
    renkler.Add "2-2", RGB(255, 255, 180)
    renkler.Add "3-1", RGB(220, 255, 220)
    renkler.Add "3-2", RGB(200, 230, 255)
    renkler.Add "3-3", RGB(220, 220, 255)
    renkler.Add "4-1", RGB(255, 200, 255)
    renkler.Add "4-3", RGB(220, 255, 255)
    renkler.Add "4-4", RGB(240, 240, 240)
    renkler.Add "5-1", RGB(255, 210, 210)
    renkler.Add "5-3", RGB(230, 230, 210)
    renkler.Add "5-5", RGB(210, 255, 230)
    renkler.Add "6-1", RGB(230, 210, 255)
    renkler.Add "6-6", RGB(210, 230, 210)
    renkler.Add "7-1", RGB(255, 230, 230)
    renkler.Add "7-3", RGB(210, 210, 230)
    renkler.Add "7-7", RGB(230, 255, 210)
    renkler.Add "8-3", RGB(255, 210, 230)

    Dim donusumTablosu As Object
    Set donusumTablosu = CreateObject("Scripting.Dictionary")
    donusumTablosu.Add "1-1", "1-1"
    donusumTablosu.Add "2-1", "2-1"
    donusumTablosu.Add "2-2", "2-2"
    donusumTablosu.Add "3-1", "3-1"
    donusumTablosu.Add "3-2", "2-1"
    donusumTablosu.Add "3-3", "2-2"
    donusumTablosu.Add "4-1", "4-1"
    donusumTablosu.Add "4-3", "3-1"
    donusumTablosu.Add "4-4", "4-4"
    donusumTablosu.Add "5-1", "5-1"
    donusumTablosu.Add "5-3", "4-1"
    donusumTablosu.Add "5-5", "5-5"
    donusumTablosu.Add "6-1", "5-1"
    donusumTablosu.Add "6-6", "6-6"
    donusumTablosu.Add "7-1", "7-1"
    donusumTablosu.Add "7-3", "6-1"
    donusumTablosu.Add "7-7", "7-7"
    donusumTablosu.Add "8-3", "7-1"
    
    Dim i As Long
    For i = 2 To sonSatir
        Dim dereceKademe As String
        dereceKademe = ws.Cells(i, 3).Value
        
        If dereceKademe <> "" And donusumTablosu.Exists(dereceKademe) Then
            Dim yeniDeger As String
            yeniDeger = donusumTablosu(dereceKademe)
            
            If renkler.Exists(yeniDeger) Then
                ws.Rows(i).Interior.Color = renkler(yeniDeger)
            End If
        End If
    Next i
    MsgBox "Satırlar derece/kademe değerlerine göre renklendirildi!", vbInformation, "İşlem Tamamlandı"
End Sub

 

[Kemter]

Merhaba, ilginiz için teşekkür ederim. Makroyu denedim çalışmadı.
Makro bilgim olmadığı için acaba C sütunundaki yazılışı 8-3 > 7-1, fakat bulunmasını istediğim değer ise 8- > 7- şeklinde yazıldığı için aradaki - ile > karakterlerden kaynaklı bir durum olabilir mi?
Saygılarımla.

 

[pitchoute]

Merhaba hocam, yedek alıp şöyle dener misiniz;

Sub SatirlariRenklendir()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    
    Dim sonSatir As Long
    sonSatir = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
    
    Dim renkler As Object
    Set renkler = CreateObject("Scripting.Dictionary")
    
    renkler.Add "1-", RGB(255, 200, 200)
    renkler.Add "2-", RGB(255, 230, 180)
    renkler.Add "3-", RGB(220, 255, 220)
    renkler.Add "4-", RGB(255, 200, 255)
    renkler.Add "5-", RGB(230, 230, 210)
    renkler.Add "6-", RGB(230, 210, 255)
    renkler.Add "7-", RGB(255, 230, 230)
    renkler.Add "8-", RGB(255, 210, 230)

    Dim donusumTablosu As Object
    Set donusumTablosu = CreateObject("Scripting.Dictionary")
    
    donusumTablosu.Add "1-", "1-"
    donusumTablosu.Add "2-", "2-"
    donusumTablosu.Add "3-2", "2-"
    donusumTablosu.Add "3-3", "2-"
    donusumTablosu.Add "4-3", "3-"
    donusumTablosu.Add "5-3", "4-"
    donusumTablosu.Add "6-1", "5-"
    donusumTablosu.Add "7-3", "6-"
    donusumTablosu.Add "8-3", "7-"
    
    Dim i As Long
    For i = 2 To sonSatir
        Dim dereceKademeMetni As String
        dereceKademeMetni = ws.Cells(i, 3).Value
        
        If Trim(dereceKademeMetni) <> "" Then
            Dim parcalar As Variant
            parcalar = Split(dereceKademeMetni, ">")
            
            If UBound(parcalar) >= 0 Then
                Dim solDeger As String
                solDeger = Trim(parcalar(0))
                Dim donusumAnahtar As String
                Dim bulunanAnahtar As String
                bulunanAnahtar = ""

                Dim anahtar As Variant
                For Each anahtar In donusumTablosu.Keys()
                    If InStr(solDeger, anahtar) > 0 Then
                        If Len(anahtar) > Len(bulunanAnahtar) Then
                            bulunanAnahtar = anahtar
                        End If
                    End If
                Next anahtar
                
                If bulunanAnahtar <> "" Then
                    Dim yeniDeger As String
                    yeniDeger = donusumTablosu(bulunanAnahtar)
                    
                    If renkler.Exists(yeniDeger) Then
                        ws.Rows(i).Interior.Color = renkler(yeniDeger)
                    End If
                End If
            End If
        End If
    Next i
    MsgBox "Satırlar derece/kademe değerlerine göre renklendirildi!", vbInformation, "İşlem Tamamlandı"
End Sub

 

[Kemter]

Merhaba hocam, makronuz çalıştı emeğinize yüreğinize sağlık, ilginiz için Allah razı olsun çok teşekkür ederim.
ufak bir bölüm için ricam olacaktı mümkün ise koddaki şu yerleri
donusumTablosu.Add "8-", "7-"
donusumTablosu.Add "7-", "6-"
donusumTablosu.Add "6-", "5-"
donusumTablosu.Add "5-", "4-"
donusumTablosu.Add "4-", "3-"
donusumTablosu.Add "3-", "2-"
donusumTablosu.Add "2-", "1-"

şeklinde çalıştırılabilir mi?
Kod çalıştı fakat aşağıdaki gibi 1-1 > 1-2, 2-1 > 2-3 yani eşit olanlar gelmesin, eşit olmayanlar gelsin istiyorum. Yukarıdaki diziliş şeklinde olabilir mi?

		1-1 > 1-2	1-1 > 1-2
		2-1 > 2-3	2-1 > 2-3

Saygılarımla.