Makro İle Hücre Değeri ve Rengine göre seçilen hücrenin renklendirilmesi

[walabi]

Merhaba,

Bu sitede üzerinde koşullu biçimlendirme ile ilgili bir uygulama buldum ve kendime göre uyarlamak istedim. Ekteki dosyanın veri adlı sayfasının B sütununda veri doğrulama ile haftanın günlerini seçiyorum. Liste adlı sayfada bir satır boş olmak üzere haftanın 7 günü ile beraber toplamda 8 satır var. Yapmaya çalıştığım şey ise şu;

Veri adlı sayfanın B sütunundan bir hücreyi veri doğrulama ile doldurduğumda Liste adlı sayfadaki günün hücre rengi aynen veri sayfasına da yansısın.

Örneğin, Liste adlı sayfada B3 hücresinin değeri Pazartesi ve hücre rengi sarı, veri adlı sayfada B sütununda herhangi bir hücrede veri doğrulama ile pazartesi seçtiğimde bu hücrenin rengi de sarı olsun istiyorum.

Buna göre aşağıdaki kodlar nasıl revize edilmeli

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim oRng As Range 'Satış Danışmanının bulunduğu satırların aralığı için değişken tanımlanıyor.
Set oRng = Range("G2:G10") 'Satış Danışmanının bulunduğu satırların aralık değişkene atanıyor
Dim bulundugusatır As Integer 'Satış Danışmanınismini atamak için değişken tenımlanıyor
Dim adres As String ' Makroyu yalnızca C3 teki veriye göre açılıştırmak için aktif hücre yönteminde aktif hücre adresinin alınacağı değişken tanımlanıyor.
    If WorksheetFunction.CountA(Range("G2:G10")) > 0 Then 'Satış Danışmanının bulunduğu satırların ("G2:G10")kontrol edilerek listede isim varmı yok mu? kontrol ediliyor.
    'varsa işlem yapılıyor.
        adres = ActiveCell.Address 'aktif hücrenin adresi adres değişkenine atanıyor.

            If adres = "$C$3" Then 'aktif hücrenin adresi C3 ise
                 isim = ActiveCell.Value 'aktif hücrenin değeri isim değişkenine atanıyor.
                
                
                
                 bulundugusatır = Application.WorksheetFunction.Match(isim, oRng, 0) 'Aktif hücre (C3) teki satış danışmanı, oRng = Range("G2:G10") aralığında aranıyor.
                 'Varsa eğer kaçıncı sırada olduğu biligisi sayılsal olarak bulundugusatır değişkenine atanıyor
                
              
                
                          
                               Range("B3").Select 'B3 seçiliyor
                                   With Selection.Interior
                                       .ColorIndex = bulundugusatır 'B3 hücre rengi bulundugusatır değişkenindeki sayıya göre renk alıyor.
                                       .Pattern = xlSolid
                                   End With
            Else
                Exit Sub
            End If
    
    End If
End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range
    
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Liste")
    
    Target.Interior.Color = xlNone
    
    If Target.Value <> "" Then
        Set Bul = S2.Range("B:B").Find(Target, , , xlWhole)
        If Not Bul Is Nothing Then Target.Interior.ColorIndex = Bul.Interior.ColorIndex
    End If
    
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[walabi]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, Bul As Range
   
    Set S1 = Sheets("Veri")
    Set S2 = Sheets("Liste")
   
    Target.Interior.Color = xlNone
   
    If Target.Value <> "" Then
        Set Bul = S2.Range("B:B").Find(Target, , , xlWhole)
        If Not Bul Is Nothing Then Target.Interior.ColorIndex = Bul.Interior.ColorIndex
    End If
   
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

Çok teşekkürler Korhan bey