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

K

Kemter

Katılım
30 Nisan 2011
Mesajlar
68
Excel Vers. ve Dili
Excel-2007-2010
Altın Üyelik Bitiş Tarihi
16-04-2024
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

  
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
335
Excel Vers. ve Dili
Excel 2021 Türkçe
Merhaba, makro olarak şu makroyu dener misiniz? Yedek almayı unutmayın lütfen;

Kod: 
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
 
K

Kemter

Katılım
30 Nisan 2011
Mesajlar
68
Excel Vers. ve Dili
Excel-2007-2010
Altın Üyelik Bitiş Tarihi
16-04-2024
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.
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
335
Excel Vers. ve Dili
Excel 2021 Türkçe
Merhaba hocam, yedek alıp şöyle dener misiniz;

Kod: 
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
 
K

Kemter

Katılım
30 Nisan 2011
Mesajlar
68
Excel Vers. ve Dili
Excel-2007-2010
Altın Üyelik Bitiş Tarihi
16-04-2024
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.
 
Son düzenleme:
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
335
Excel Vers. ve Dili
Excel 2021 Türkçe
Allah sizden de razı olsun hocam.

Şu şekilde dener misiniz hocam;

Kod: 
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 "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-"
    
    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
                Dim sagDeger As String
                solDeger = Trim(parcalar(0))
                
                If UBound(parcalar) >= 1 Then
                    sagDeger = Trim(parcalar(1))
                Else
                    sagDeger = ""
                End If
                
                If solDeger <> sagDeger And sagDeger <> "" Then
                    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
        End If
    Next i
    MsgBox "Satırlar derece/kademe değerlerine göre renklendirildi!", vbInformation, "İşlem Tamamlandı"
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst