Tablodaki Hücreye Göre Renklendirme

[yanginci34]

Merhaba arkadaşlar; Elimde örnek olarak gönderdiğim 3 adet dosya bulunmakta yapmak istediğim tablo1 ve tablo2 de j ve k sütununda bulunan isimler liste sayfasında mevcut. Ben liste dosyasından tablo1 ve tablo2 deki aynı ismi bulup tablo1 ve tablo2 deki hücrenin dolgu rengi ile aynı dolgu renk olarak yapmak istiyorum. Umarım anlatabilmişimdir.

 

[Korhan Ayhan]

Bütün dosyalarınızı aynı klasöre alıp aşağıdaki kodu "liste" isimli dosyanıza uygulayıp çalıştırınız.

Option Explicit

Sub Renklendir()
    Dim K1 As Workbook, K2 As Workbook, K3 As Workbook
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim Alan As Range, Veri As Range, Bul As Range
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Sayfa1")
    Set K2 = Workbooks.Open(K1.Path & "\tablo1.xls")
    Set S2 = K2.Sheets(1)
    Set K3 = Workbooks.Open(K1.Path & "\tablo2.xls")
    Set S3 = K3.Sheets(1)
    
    Set Alan = S1.Range("A3:P" & S1.Cells(S1.Rows.Count, "F").End(3).Row - 7)
    Alan.Interior.Color = xlNone
    
    For Each Veri In Alan
        If Veri.Value <> "" And S1.Cells(2, Veri.Column) = "ADI SOYADI" Then
            Set Bul = S2.Range("J:K").Find(Veri.Value, , , xlPart)
            If Not Bul Is Nothing Then
                Veri.Interior.ColorIndex = Bul.Interior.ColorIndex
                GoTo 10
            End If
        
            Set Bul = S3.Range("J:K").Find(Veri.Value, , , xlPart)
            If Not Bul Is Nothing Then
                Veri.Interior.ColorIndex = Bul.Interior.ColorIndex
            End If
        End If
10  Next

    K2.Close 0
    K3.Close 0

    Application.ScreenUpdating = True

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub