• DİKKAT

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

Sayfada Tanımlanan Renkleri Koşullu Atamak

B

baydeniro

Katılım
26 Ocak 2007
Mesajlar
4,625
Excel Vers. ve Dili
Ofis 2016
Merhaba Arkadaşlar,

B Sütununa veri girildiğinde, solundaki ve sağındaki hücreler (A ve C sütunu) o verinin KOŞUL sayfasında tanımlanan rengi alması mümkün mü !

http://dosya.co/qvo3s3nc9zdr/KOSULLU_RENKLENDİRME.xls.html
 
Aşağıdaki kodu bir modüle ekleyip
butona makroyu atayınız.

Yalnız koşullu biçimlendirme için sağlıklı bir makro değil,
peşinen söyleyeyim.


Kod: 
Sub renkver()
 For i = 2 To 65536
 If Range("b" & i) <> "" Then


 Range("C2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 192
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("C3").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("C4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Range("C5").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.349986266670736
        .PatternTintAndShade = 0
    End With
    Range("C6").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Range("C4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
 
    
    'aaa
    
    Range("A2").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 192
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A3").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Range("A4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .Color = 49407
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Range("A5").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.349986266670736
        .PatternTintAndShade = 0
    End With
    Range("A6").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorLight2
        .TintAndShade = 0.399975585192419
        .PatternTintAndShade = 0
    End With
    Range("A4").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    End If
    
    Next i
End Sub
 
Sayın BedriA ilginize ve ko için çok teşekkür ediyorum. Dediğiniz gibi kod pek randımanlı çalışmıyor.
 
Dener misiniz?
Kod: 
Sub Renkbak()
Zaman = Timer
Application.ScreenUpdating = False
Set s1 = Sheets("KAYIT")
Set s2 = Sheets("KOŞUL")
On Local Error Resume Next
Dim i As Long
For i = 2 To s1.Range("B65500").End(3).Row
bul = WorksheetFunction.Match(s1.Range("B" & i), s2.Range("A2:A" & s2.Range("A65500").End(3).Row), 0) + 1
renk = s2.Range("b" & bul).Interior.Color
    s1.Range("a" & i).Resize(1, 3).Interior.Color = renk
    If Err.Number = 1004 Then
s1.Range("a" & i).Resize(1, 3).Interior.Color = xlNone
       Err.Clear
        End If
Next
i = Empty
Application.ScreenUpdating = True
MsgBox ("İşlem Bitirilmiştir" & vbLf & "makronun süresi " & Format(Timer - Zaman, "0.00")), vbInformation
End Sub
 
Son düzenleme:
çıtır üstadım bu kod çok güzel oldu. Tam da budur. Çok teşekkür ediyorum, Allah razı olsun sizden. Sağlıcakla kalın.
 
serdarokan' Alıntı:
çıtır üstadım bu kod çok güzel oldu. Tam da budur. Çok teşekkür ediyorum, Allah razı olsun sizden. Sağlıcakla kalın.
Genişletmek için tıkla ...
Rica ederim,sizdende Allah razı olsun.Küçük değişiklikle.Private Sub Worksheet_SelectionChange(ByVal Target As Range) olarak sayfayada ayarlanabilir.İyi geceler.
 
Merhaba.

Alternatif olsun.

Aşağıdaki birinci kod çalıştırıldığında
(Modül veya KOŞUL sayfasının KOŞUL kod bölümüne uygulayın);
KOŞUL sayfasına uyguladığınız renklerin sayısal kod karşılıkları C sütununa yazdırılır.
Bu renk kodları diğer sayfadaki renklendirmede kullanılır.
(Renkleri değiştirdiğinizde veya yeni renk türü eklemek istediğinizde bu kodu bir kez çalıştırmanız gerekir)
.
Kod: 
Sub RENKLER()
For sat = 2 To Sheets("KOŞUL").Cells(Rows.Count,"A").End(xlup).Row
    Sheets("KOŞUL").Cells(sat, 3) = Cells(sat, 2).Interior.Color
Next
End Sub
-- Aşağıdaki kod'u KAYIT sayfasının kod bölümüne uygulayın ve B sütununa ürün adlarını yazın/değiştirin/silin.
.
Kod: 
[B]Private Sub Worksheet_Change(ByVal Target As Range)[/B]
alan = "B2:B" & [A1].SpecialCells(xlCellTypeLastCell).Row
Set k = Sheets("KOŞUL")
If Intersect(Target, Range(alan)) Is Nothing Then Exit Sub
If Target = "" Then
    Range("A" & Target.Row & ":C" & Target.Row).Clear: Exit Sub
End If
If WorksheetFunction.CountIf(k.Range("A:A"), Target) > 0 Then
    sat = WorksheetFunction.Match(Target, k.Range("A:A"), 0)
    With Range("A" & Target.Row & ":C" & Target.Row)
        .Interior.Color = k.Cells(sat, 3)
        .Font.Bold = True:.Font.Color = vbWhite
    End With
    Exit Sub
End If
[B]End Sub[/B]
 
Ömer Baran üstadım ilginize çok teşekkür ediyorum. Kod aşağıdaki satırda hata verdi :

For sat = 2 To Sheets("KOŞUL").Cells(Rows.Count,"A").End(xlup).Row)
 
En sondaki parantezi silin, varsa Row kelimesinin arasındaki boşluğu da silin.
 
Kayıt sayfasının kod kısmına
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Intersect(Target, Range("b2:b65500")) Is Nothing Then Exit Sub
Set s1 = Sheets("KAYIT")
Set s2 = Sheets("KOŞUL")
On Local Error Resume Next
Dim i As Long
For i = 2 To s1.Range("B65500").End(3).Row
bul = WorksheetFunction.Match(s1.Range("B" & i), s2.Range("A2:A" & s2.Range("A65500").End(3).Row), 0) + 1
renk = s2.Range("b" & bul).Interior.Color
    s1.Range("a" & i).Resize(1, 3).Interior.Color = renk
    If Err.Number = 1004 Then
s1.Range("a" & i).Resize(1, 3).Interior.Color = xlNone
       Err.Clear
        End If
Next
i = Empty
Application.ScreenUpdating = True
End Sub
Küçük bir değişiklik yaptım,diğer kod 11 satır(koşul) dikkate alıyor .Düzelttim.Hoşcakalın
 
Son düzenleme:
çıtır üstadım çok teşekkür ediyorum. Bir konuda fikrinizi almak isterim. KOŞUL sayfasında belirlediğim renklere yakın tonlarda ama farklı renkler atıyor. Gerçi önemi yok. Bilgilenmek için merak ettim. Bunun nedeni ne olabilir acaba ?
 
Tekrar merhaba.

Sanırım Sayın çıtır çevrimdışı.
Sayın çıtır'ın verdiği kodlardaki ColorIndex kısımlarını Color olarak değiştirerek deneyin.
.
 
Ömer BARAN' Alıntı:
Tekrar merhaba.

Sanırım Sayın çıtır çevrimdışı.
Sayın çıtır'ın verdiği kodlardaki ColorIndex kısımlarını Color olarak değiştirerek deneyin.
.
Genişletmek için tıkla ...

Ömer Baran üstadım çok çok teşekkür ederim. Gerçekten bu şekilde mükemmel oldu. İyi ki varsınız. Sağlıcakla kalın.
 
Sayın Ömer BARAN üstadım cevabın ve uyarın için çok teşekkür ederim.İyi ki varsınız.
Sayın serdarokan küçük düzeltmeler yaptım.Olmayan ürün olursa renksiz yapıyor.Aksi halde son ürünün rengi geliyordu.Kolay gelsin.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst