• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

satırdaki isimlerin listede renklenmesi

Katılım
20 Şubat 2012
Mesajlar
150
Excel Vers. ve Dili
2007 türkçe
merhaba arkadaşlar
örnekte bahsettiğim gibi tarihi seçtiğimizde o tarih satırındaki isimleri yan tarafdaki listede nasıl renklendirebiliriz?
yardımcı olabilir misiniz? teşekür ederim
 

Ekli dosyalar

Sayfa kodu olarak kopyalayınız.
Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Selection.Count > 1 Then Exit Sub
If Target.Column > 1 Then
Range("M1:M20").Interior.ColorIndex = xlNone
End If
If Intersect(Target, [A1:A5]) Is Nothing Then Exit Sub
For i = 1 To 20
    sy = WorksheetFunction.CountIf(Range(Cells(Target.Row, 2), Cells(Target.Row, 9)), Range("M" & i))
    If sy > 0 Then
     Range("M" & i).Interior.ColorIndex = 3
     Else
    Range("M" & i).Interior.ColorIndex = 1
     End If
   Next i
   End Sub
 
Son düzenleme:
Merhaba,
Alternatif Olsun. M sütununda değerlerde artış olursa da dikkate alır.
Tabloda bulunmayan değerlerde işaretlenir.
Aşağıdaki kodları ilgili sayfanın kod bölümüne kopyalayıp deneyiniz.

Kod:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    Dim i   As Integer, _
        j   As Integer, _
        k   As Integer, _
        c   As Range
    
    j = Cells(Rows.Count, "M").End(3).Row
    k = Cells(Rows.Count, "A").End(3).Row
    
    Range("B1:I" & k).Interior.ColorIndex = xlNone
    Range("M1:M" & j).Interior.ColorIndex = xlNone
    
    If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
    If Target.Value = "" Or Target.Column > 1 Then Exit Sub
    
    For i = 2 To 9
        If Not Cells(Target.Row, i) = "" Then
            Set c = Range("M1:M" & j).Find(Cells(Target.Row, i), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                c.Interior.ColorIndex = 3
            Else
                Cells(Target.Row, i).Interior.ColorIndex = 3
            End If
        End If
    Next i
    
End Sub
 
Son düzenleme:
ilginiz ve cevaplarınız için teşekkür ederim .
 
ilginiz ve cevaplarınız için teşekkür ederim
 
Geri
Üst