Dolgu rengi

[mesutaygun70]

Sayfa1 de A sutununda malzemeler var( Elma , armut vs.) B sutununda da değerler var 1-20 arasında
Sayfa 2 de aynı malzeme isimleri var ama çoğu birleştirilmiş hücre

sayfa2 deki malzemelerin sayfa 1 deki değere göre her rakam için bir dolgu rengi almasını istiyorum. Bir yolu varmıdır.

calisma.xlsx dosyasını indir - download

calisma.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[Korhan Ayhan]

Mesela Elma ve Ayva karşısındaki değer 5 bu durumda iki ürün aynı rengi mi alacak?

 

[mesutaygun70]

Mesela Elma ve Ayva karşısındaki değer 5 bu durumda iki ürün aynı rengi mi alacak?

evet her değer için aynı renk (1 için sarı, 2 için kırmızı gibi) 20 yi geçmez (örnek olarak bana 3 tane yapsanız ben devamını getirebilirim)

 

[Korhan Ayhan]

Deneyiniz.

Renk paletinde istediğiniz renkleri belirleyebilirsiniz.

Option Explicit

Sub Renklendir()
    Dim S1 As Worksheet, S2 As Worksheet
    Dim Renkler As Variant, Deger As Variant
    Dim Veri As Range, Bul As Range, X As Byte
    
    Application.ScreenUpdating = 0
    
    Set S1 = Sheets("Sheet1")
    Set S2 = Sheets("Sayfa1")
    
    Deger = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 1, 17, 18, 19, 20)
    Renkler = Array(3, 4, 5, 6, 7, 8, 15, 16, 22, 23, 26, 28, 33, 36, 40, 43, 44, 45, 46, 47)
    
    S2.UsedRange.Interior.ColorIndex = -4142
    
    For Each Veri In S2.UsedRange
        If Veri.Value <> "" Then
            Set Bul = S1.Range("A:A").Find(Trim(Veri.Value), , , xlWhole)
            If Not Bul Is Nothing Then
                X = WorksheetFunction.Match(Bul.Offset(, 1), Deger, 0)
                Veri.MergeArea.Interior.ColorIndex = Renkler(X)
            End If
        End If
    Next

    Set Bul = Nothing
    Set S1 = Nothing
    Set S2 = Nothing

    Application.ScreenUpdating = 1

    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub