• DİKKAT

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

2 sütundaki aynı sayıları bulma ve birbirinden ayırma

S

sezgingultekin

Katılım
3 Aralık 2019
Mesajlar
14
Excel Vers. ve Dili
Excel 2010 - Türkçe
Arkadaşlar merhaba,

Elimde 2 sütündan oluşan bir excel dosyası var. Biri A sütünü biri B sütünu. Ben A sütununda ki sayıdan şayet B sütununda varsa onu renklendirmesini istiyorum. Yalnız bu sayılar yanyana kutucuklarda değil. Örn. birisi A21 diğeri B45 dedir. Birde aynı sayılardan aşağıki kutucuklarda yine var. Hepsini ayrı ayrı renklendirmesi mümkün mü? Mesala 50 rakamı A1de var diğeri B5te bunları buldu ve sarı yaptı yada benim anlayacağım şekilde bana belirtti. Ama 50 rakamı A45de diğeri B89 da var onuda bana bulup değişik bir şekilde benim anlayacağım şekilde gösterebilir mi? Lütfen yardımlarınızı bekliyorum
 
Tek renk isterseniz koşullu biçimlendirme ile yapabilirsiniz.
 
Korhan Ayhan' Alıntı:
Tek renk isterseniz koşullu biçimlendirme ile yapabilirsiniz.
Genişletmek için tıkla ...
tek renkte yapsam a sütunundaki bütün 50 lileri de alıyor. Ben onu istemiyorum. A5 deki 50 ile B20 deki 50 işaretlesin ama A8 de yine 50 var B55 de de 50 var o 50 lerin yukardaki 50 lerden farklı olduğunu göstersin istiyorum
 
Örnek dosya üzerinde tarif ederseniz daha anlaşılır olacaktır.
 
[url=https://hizliresim.com/d2vfb2][/URL]

ÖRNEKTEKİ GİBİ YA RENKLENDİRMESİNİ YA DA ANLAŞILACAK ŞEKİLDE AYIRMASINI İSTİYORUM. AMA BAKIN A' DA 126 2 KERE YAZILMIŞ VE B DEDE 2 KERE YAZILDIĞI İÇİN RENKLERİ FARKLI. TAM TERCÜME EDEMEDİM SANIRIM :(
 
Örnek dosya talep ettim. Siz resim paylaştınız.

Bazen kendimi ifade edemediğimi düşünüyorum.

Paylaştığınız görsele göre makro kullanmak daha uygun görünüyor.

Veri sayınız nedir?
 
Deneyiniz.

C++: 
Option Explicit

Sub Ayni_Olanlari_Renklendir()
    Dim Renkler As Object, Veri As Range, Son As Long
    Dim Bul As Range, Adres As String, Renk As Variant
    Dim Kod1 As Byte, Kod2 As Byte, Kod3 As Byte
   
    Application.ScreenUpdating = False
   
    Set Renkler = CreateObject("Scripting.Dictionary")
   
    Range("A2:B" & Rows.Count).Interior.Color = -4142
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    For Each Veri In Range("A2:A" & Son)
        If Veri.Value <> "" Then
            Set Bul = Range("B:B").Find(Veri.Value, , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Interior.ColorIndex = -4142 Then
10                      Kod1 = Evaluate("=RANDBETWEEN(1,255)")
                        Kod2 = Evaluate("=RANDBETWEEN(1,255)")
                        Kod3 = Evaluate("=RANDBETWEEN(1,255)")
                        Renk = RGB(Kod1, Kod2, Kod3)
                       
                        If Not Renkler.Exists(Renk) Then
                            If Renk = 16777215 Then GoTo 10
                            Renkler.Add Renk, Nothing
                            Bul.Interior.Color = Renk
                            Veri.Interior.Color = Renk
                            Exit Do
                        Else
                            GoTo 10
                        End If
                    End If
                   
                    Set Bul = Range("B:B").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next

    Set Renkler = Nothing

    Application.ScreenUpdating = True
   
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub
 
Alternatif olarak
Formülle çözümlenerek koşullu biçimlendirme yapılmış örnek ektedir. İncelersiniz...

Not : Bana göre, koşullu biçimlendirme karmaşık ve ilgili değerleri bulma zorluğu çekiliyor.
Bu nedenle de karşılık gelen değerlerin adresleri, adreslerdeki değerler ve tekrar adetleri formüllerle yazdırıldı.

Kitap1_160920.xlsx dosyasını indir - download

Kitap1_160920.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s7.dosya.tc s7.dosya.tc
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Ayni_Olanlari_Renklendir()
    Dim Renkler As Object, Veri As Range, Son As Long
    Dim Bul As Range, Adres As String, Renk As Variant
    Dim Kod1 As Byte, Kod2 As Byte, Kod3 As Byte
   
    Application.ScreenUpdating = False
   
    Set Renkler = CreateObject("Scripting.Dictionary")
   
    Range("A2:B" & Rows.Count).Interior.Color = -4142
   
    Son = Cells(Rows.Count, 1).End(3).Row
   
    For Each Veri In Range("A2:A" & Son)
        If Veri.Value <> "" Then
            Set Bul = Range("B:B").Find(Veri.Value, , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Interior.ColorIndex = -4142 Then
10                      Kod1 = Evaluate("=RANDBETWEEN(1,250)")
                        Kod2 = Evaluate("=RANDBETWEEN(1,250)")
                        Kod3 = Evaluate("=RANDBETWEEN(1,250)")
                        Renk = RGB(Kod1, Kod2, Kod3)
                       
                        If Not Renkler.Exists(Renk) Then
                            If Renk = 16777215 Then GoTo 10
                            Renkler.Add Renk, Nothing
                            Bul.Interior.Color = Renk
                            Veri.Interior.Color = Renk
                            Exit Do
                        Else
                            GoTo 10
                        End If
                    End If
                   
                    Set Bul = Range("B:B").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next

    Set Renkler = Nothing

    Application.ScreenUpdating = True
   
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Korhan Ayhan uzmanım merhaba
size zahmet olmazsa
A ve B sütunundaki renklendirmeleri
D ve E de yaptığım gibi veya
G ve H de yaptığım gibi
(hangisi sizi az uğraştıracaksa)
tek renk olacak şekilde değiştirebilir misiniz? Eğer kolay ise ikisi de ayrı ayrı olsa iyi olur :)
Saygılar

esitlik_kontrol.xlsm dosyasını indir - download

esitlik_kontrol.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s7.dosya.tc s7.dosya.tc
 
Verileriniz sıralı ise aslında renklendirmeye gerek yok.

C2 hücresine aşağıdaki formülü yazıp alt hücrelere sürüklerseniz işinizi görecektir.

C++: 
=A2=B2

Ek olarak makro ile renklendirme için aşağıdaki kodları kullanabilirsiniz.

C++: 
Option Explicit

Sub Ayni_Olanlari_Renklendir()
    Dim Veri As Range, Son As Long
    
    Application.ScreenUpdating = False
    
    Range("A2:B" & Rows.Count).Interior.Color = -4142
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For Each Veri In Range("A2:A" & Son)
        If Veri.Value <> "" Then
            If Veri.Value = Veri.Offset(0, 1) Then Veri.Resize(, 2).Interior.ColorIndex = 6
        End If
    Next

    Application.ScreenUpdating = True
    
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub

Sub Ayni_Olmayanlari_Renklendir()
    Dim Veri As Range, Son As Long
    
    Application.ScreenUpdating = False
    
    Range("A2:B" & Rows.Count).Interior.Color = -4142
    
    Son = Cells(Rows.Count, 1).End(3).Row
    
    For Each Veri In Range("A2:A" & Son)
        If Veri.Value <> "" Then
            If Veri.Value <> Veri.Offset(0, 1) Then Veri.Resize(, 2).Interior.ColorIndex = 6
        End If
    Next

    Application.ScreenUpdating = True
    
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub
 
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Ayni_Olanlari_Renklendir()
    Dim Renkler As Object, Veri As Range, Son As Long
    Dim Bul As Range, Adres As String, Renk As Variant
    Dim Kod1 As Byte, Kod2 As Byte, Kod3 As Byte
  
    Application.ScreenUpdating = False
  
    Set Renkler = CreateObject("Scripting.Dictionary")
  
    Range("A2:B" & Rows.Count).Interior.Color = -4142
  
    Son = Cells(Rows.Count, 1).End(3).Row
  
    For Each Veri In Range("A2:A" & Son)
        If Veri.Value <> "" Then
            Set Bul = Range("B:B").Find(Veri.Value, , , xlWhole)
            If Not Bul Is Nothing Then
                Adres = Bul.Address
                Do
                    If Bul.Interior.ColorIndex = -4142 Then
10                      Kod1 = Evaluate("=RANDBETWEEN(1,255)")
                        Kod2 = Evaluate("=RANDBETWEEN(1,255)")
                        Kod3 = Evaluate("=RANDBETWEEN(1,255)")
                        Renk = RGB(Kod1, Kod2, Kod3)
                      
                        If Not Renkler.Exists(Renk) Then
                            If Renk = 16777215 Then GoTo 10
                            Renkler.Add Renk, Nothing
                            Bul.Interior.Color = Renk
                            Veri.Interior.Color = Renk
                            Exit Do
                        Else
                            GoTo 10
                        End If
                    End If
                  
                    Set Bul = Range("B:B").FindNext(Bul)
                Loop While Not Bul Is Nothing And Bul.Address <> Adres
            End If
        End If
    Next

    Set Renkler = Nothing

    Application.ScreenUpdating = True
  
    MsgBox "Renklendirme işlemi tamamlanmıştır.", vbInformation
End Sub
Genişletmek için tıkla ...

Gerçekten çok teşekkür ederim. Tamda istediğim buydu elinize sağlık :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst