A kolonu değerlerini diğer kolonlarda arayıp renklendirmek.

Katılım
9 Ocak 2008
Mesajlar
35
Excel Vers. ve Dili
Excel 2007 Türkçe
Merhaba, A kolonundaki değerlerin herbiri, B kolonunun içinde var ise, A kolonundaki değer ile B kolonunda yer alan A kolonundaki değerin eşiti olan değer aynı renkte renkte olsun. örneğin A35 hücresindeki değer ile B67 hücresindeki değerin birbirinin aynı olduğunu düşünelim bu durumda, A35 ile B67 hücresi sarı olsun.
aynı mantıkla örneğin, A87 ile B132 değeri aynı ise, A87 ile B132 hücresi yeşil renk olsun.

Mümkün müdür, çok teşekküler
 

Ekli dosyalar

İ

İhsan Tank

Misafir
Merhaba, A kolonundaki değerlerin herbiri, B kolonunun içinde var ise, A kolonundaki değer ile B kolonunda yer alan A kolonundaki değerin eşiti olan değer aynı renkte renkte olsun. örneğin A35 hücresindeki değer ile B67 hücresindeki değerin birbirinin aynı olduğunu düşünelim bu durumda, A35 ile B67 hücresi sarı olsun.
aynı mantıkla örneğin, A87 ile B132 değeri aynı ise, A87 ile B132 hücresi yeşil renk olsun.

Mümkün müdür, çok teşekküler
merhaba
B sütununu seçin
Koşullu biçimlendirme - yeni kural - biçimlendirilecek hücreleri belirlemek için formül kullan - kutucuğa
Kod:
=EĞERSAY($A:$A;$B1)>0
biçim'i ayarlayın
A sütununu seçin
koşullu biçimlendirme - yeni kural - biçimlendirilecek hücreleri belirlemek için formül kullan - kutucuğa
Kod:
=EĞERSAY($B:$BA;$A1)>0
biçim'i ayarlayın.
kod ile isterseniz boş bir module kopyalayın ve deneyin
Kod:
Option Explicit
Sub boya()
Dim ts, kaplan
kaplan = MsgBox("Aynı Olanları Boyuyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
For ts = 3 To Cells(65536, "B").End(xlUp).Row
If WorksheetFunction.CountIf(Range("A3:A65536"), Cells(ts, "B")) > 0 Then
Cells(ts, "B").Interior.ColorIndex = 4
End If
Next
For ts = 3 To Cells(65536, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Range("B3:B65536"), Cells(ts, "A")) > 0 Then
Cells(ts, "A").Interior.ColorIndex = 4
End If
Next
Application.DisplayAlerts = True
MsgBox "Eşit Olanları Boyadım", vbInformation, "Bitiş"
End Sub
 
Katılım
9 Ocak 2008
Mesajlar
35
Excel Vers. ve Dili
Excel 2007 Türkçe
Öncelikle ilginize çok teşekkür ederim, ancak benim rica ettiğim, ekteki gibi bir sonuç verecek çalışma. yani, a kolonundaki değer b kolonunda var ise ikisi de aynı hücre rengine boyansın. tekrar teşekkürler..
 

Ekli dosyalar

İ

İhsan Tank

Misafir
Öncelikle ilginize çok teşekkür ederim, ancak benim rica ettiğim, ekteki gibi bir sonuç verecek çalışma. yani, a kolonundaki değer b kolonunda var ise ikisi de aynı hücre rengine boyansın. tekrar teşekkürler..
siz tek renk olsun istemediniz mi_?
her eşit olan'a ayrı ayrı mı renk verilecek yani bunu mu anlamalıyım.
 
İ

İhsan Tank

Misafir
yani her iki kolondaki iki eşit değer aynı renkte olacak..
merhaba
boş bir module kopyalayın ve deneyin.
Not : Excel'deki renk sayısı kadar renklendirir sonra hata verir bilginiz olsun.
yani 56 adet renk tanımlar
Kod:
Option Explicit
Sub boya()
On Error Resume Next
Dim ts, kaplan
kaplan = MsgBox("Aynı Olanları Boyuyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
kaplan = 3
For ts = 3 To Cells(65536, "B").End(xlUp).Row
If WorksheetFunction.CountIf(Range("A3:A65536"), Cells(ts, "B")) > 0 Then
Cells(ts, "B").Interior.ColorIndex = kaplan
Cells(ts, "D") = kaplan
kaplan = kaplan + 1
End If
Next
For ts = 3 To Cells(65536, "B").End(xlUp).Row
If WorksheetFunction.CountIf(Range("B3:B65536"), Cells(ts, "A")) > 0 Then
Cells(ts, "A").Interior.ColorIndex = WorksheetFunction.VLookup( _
Cells(ts, "A"), Range("B3:D65536"), 3, 0)
End If
Next
Range("D:D").ClearContents
Application.DisplayAlerts = True
MsgBox "Eşit Olanları Boyadım", vbInformation, "Bitiş"
End Sub
 
Katılım
9 Ocak 2008
Mesajlar
35
Excel Vers. ve Dili
Excel 2007 Türkçe
Uğraştığınız için çok teşekkür ederim. ancak yine olmamış. her iki ayrı kolonda aynı olan değerleri aynı renk'e boyaması gerekiyor. yani diyelim A kolonunda ST360304636 değeri B kolonunda da var. bu değer her iki kolonda da yeşil renkte olsun. yine, A kolonunun başka bir satırında SA060839754 değeri bulunuyor ve bu değer B kolonunun herhangi bir satırında da mevcut. bu değer de örneğin kırmızı renge boyansın. tekrar teşekkürler.
 
İ

İhsan Tank

Misafir
Uğraştığınız için çok teşekkür ederim. ancak yine olmamış. her iki ayrı kolonda aynı olan değerleri aynı renk'e boyaması gerekiyor. yani diyelim A kolonunda ST360304636 değeri B kolonunda da var. bu değer her iki kolonda da yeşil renkte olsun. yine, A kolonunun başka bir satırında SA060839754 değeri bulunuyor ve bu değer B kolonunun herhangi bir satırında da mevcut. bu değer de örneğin kırmızı renge boyansın. tekrar teşekkürler.
ben deniyorum bir problem yok
başka arkadaş'a denettirdim gene problem olmadığını söyledi
bir de siz ilk dosyadan bahsediyorsanız olmadı falan diye birbirine eşit olmalı metin yazmışsanız metin rakam yazmışsanız rakam olmalı eşitlik sağlanmalı yani
 
Katılım
9 Ocak 2008
Mesajlar
35
Excel Vers. ve Dili
Excel 2007 Türkçe
7 tane farklı renge boyanmış satır görünüyor. ancak bu satırlarda değer yok. sadece hücrenin üzeri renkli, mavi sarı, pembe falan.. hücrenin içindeki değer görünsün, sadece değer renklensin, örneğin kırmızı olsun, bu kırmızı ile boyanmış değerin aynısı, A hücresinde de kırmızı olsun. bu şekilde izah etmeye çalışmıştım, anlatamadığım için çok özür, saygılar.
 
İ

İhsan Tank

Misafir
7 tane farklı renge boyanmış satır görünüyor. ancak bu satırlarda değer yok. sadece hücrenin üzeri renkli, mavi sarı, pembe falan.. hücrenin içindeki değer görünsün, sadece değer renklensin, örneğin kırmızı olsun, bu kırmızı ile boyanmış değerin aynısı, A hücresinde de kırmızı olsun. bu şekilde izah etmeye çalışmıştım, anlatamadığım için çok özür, saygılar.
doğru boş hücreleri boyuyor sebebi ise karşılığı olduğu için
hepsi dolu olursa dolduğu şekle göre boyar.
 
İ

İhsan Tank

Misafir
B sütununda fazla boşluk var bunları görüyor ve karşılık olarak da boşluk gördüğünde otomatik veri olduğunu sayıyor
Kod:
Option Explicit
Sub boya()
On Error Resume Next
Range("A3:B65536").Interior.Pattern = xlNone
Dim ts, kaplan
kaplan = MsgBox("Aynı Olanları Boyuyorum", vbYesNo, "Onay")
If kaplan = vbNo Then Exit Sub
Application.DisplayAlerts = False
kaplan = 3
For ts = 3 To Cells(65536, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Range("A3:A65536"), Cells(ts, "B")) > 0 Then
Cells(ts, "B").Interior.ColorIndex = kaplan
Cells(ts, "D") = kaplan
kaplan = kaplan + 1
End If
Next
For ts = 3 To Cells(65536, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Range("B3:B65536"), Cells(ts, "A")) > 0 Then
Cells(ts, "A").Interior.ColorIndex = WorksheetFunction.VLookup( _
Cells(ts, "A"), Range("B3:D65536"), 3, 0)
End If
Next
Range("D:D").ClearContents
Application.DisplayAlerts = True
MsgBox "Eşit Olanları Boyadım", vbInformation, "Bitiş"
End Sub
bu kod A sütunundaki veri sayısına göre çalışır. B sütununda buna göre 2 tane boşluk mevcut.
bunları doldurun ve karşılıklarınıda yazın kodu çalıştırın.
 

Ömer

Moderatör
Yönetici
Katılım
18 Ağustos 2007
Mesajlar
22,184
Excel Vers. ve Dili
Microsoft 365 Tr
Ofis 2016 Tr
Merhaba,

Alternatif olsun.

Eğer mükerrer veriler 56 dan fazla ise renk kodu sıfırlanıp tekrar renklendirmeye devam eder. Yalnız buradaki sorun farklı 2 kayıta aynı renk gelebilir.

Dilerseniz bunun için C sütununa 1-2-3... şeklinde aynı renklere farklı numara verdirilebilir.

Kod:
Sub BulBoya()
 
    Dim i As Long, c As Range, Adr As String, say As Byte, artis As Byte
 
    [A:B].Interior.ColorIndex = 0
 
    For i = 3 To Cells(Rows.Count, "A").End(xlUp).Row
       With Range("B:B")
           Set c = .Find(Cells(i, "A"), LookIn:=xlValues, LookAt:=xlWhole)
           If Not c Is Nothing Then
               Adr = c.Address
               Do
                   artis = 1
                   If Cells(i, "A") <> "" Then
                       If say = 1 Then artis = 2
                       say = say + artis
                       Cells(i, "A").Interior.ColorIndex = say
                       Cells(c.Row, "B").Interior.ColorIndex = say
                   End If
 
                   If say Mod 56 = 0 Then say = 0
                   Set c = .FindNext(c)
               Loop While Not c Is Nothing And c.Address <> Adr
           End If
       End With
    Next i
 
    MsgBox "İşlemi Tamamladım.", vbInformation, "excel.web.tr"
 
End Sub
.
 
Üst