Mükerrer Kayıtları Renklendirme Hk.

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Değerli üstatlar paylamış olduğum çalışmamda mükerrer olan isim ve Tc kimlik numaralarını renklendiriyorum. Ancak makroda şöyle bir sıkıntı var mükerrer kaydın bir tanesini silip tekrar makroyu çalıştırdığımda sildiğim mükerrer kaydın dolgu rengi hücrede kalıyor. Aynı zamanda satır aralarında boşluk olunca yani arada veri kaydı olmayınca boş hücreleri de renklendiriyor. Buna nasıl bir çözüm bulabiliriz. Saygılar
 

Ekli dosyalar

M

mrwarrior

Katılım
26 Ocak 2013
Mesajlar
232
Excel Vers. ve Dili
Excel 2016 Türkçe
Altın Üyelik Bitiş Tarihi
26-11-2023
Hocam ben satırlarımın başına
Kod: 
    Dim Hucre As Range
    For Each Hucre In ActiveSheet.Range("A1:AA1000")
    Hucre.Interior.ColorIndex = xlNone
    Next
şeklinde başlatarak önce renksiz hale çeviriyorum. Böylece her çalıştırdığımda otomatikman renksiz yapıp tekrar boyuyor.
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,372
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

İki koşulda aynı anda gerçekleşen mükerrer kayıtları renklendirir.

C++: 
Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Zaman As Double, S1 As Worksheet, Dizi As Object, Veri As Variant
    Dim Son As Long, X As Long, Aranan As String, Alan As Range
    
    Zaman = Timer
    
    Set S1 = Sheets("ANA SAYFA")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 2 Then Son = 3
    
    S1.Range("B2:C" & S1.Rows.Count).Interior.ColorIndex = xlNone
    
    Veri = S1.Range("B2:C" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Aranan = Veri(X, 1) & "|" & Veri(X, 2)
            If Not Dizi.Exists(Aranan) Then
                Dizi.Add Aranan, 1
            Else
                Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
            End If
        End If
    Next

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 1) & "|" & Veri(X, 2)
        If Dizi.Item(Aranan) > 1 Then
            If Alan Is Nothing Then
                Set Alan = S1.Cells(X + 1, 2).Resize(1, 2)
            Else
                Set Alan = Application.Union(Alan, S1.Cells(X + 1, 2).Resize(1, 2))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.Interior.ColorIndex = 6

    Set S1 = Nothing
    Set Dizi = Nothing

    MsgBox "Mükerrer kayıtlar renklendirilmiştir." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Korhan Ayhan' Alıntı:
Deneyiniz.

İki koşulda aynı anda gerçekleşen mükerrer kayıtları renklendirir.

C++: 
Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim Zaman As Double, S1 As Worksheet, Dizi As Object, Veri As Variant
    Dim Son As Long, X As Long, Aranan As String, Alan As Range
    
    Zaman = Timer
    
    Set S1 = Sheets("ANA SAYFA")
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 2 Then Son = 3
    
    S1.Range("B2:C" & S1.Rows.Count).Interior.ColorIndex = xlNone
    
    Veri = S1.Range("B2:C" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Aranan = Veri(X, 1) & "|" & Veri(X, 2)
            If Not Dizi.Exists(Aranan) Then
                Dizi.Add Aranan, 1
            Else
                Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
            End If
        End If
    Next

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 1) & "|" & Veri(X, 2)
        If Dizi.Item(Aranan) > 1 Then
            If Alan Is Nothing Then
                Set Alan = S1.Cells(X + 1, 2).Resize(1, 2)
            Else
                Set Alan = Application.Union(Alan, S1.Cells(X + 1, 2).Resize(1, 2))
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.Interior.ColorIndex = 6

    Set S1 = Nothing
    Set Dizi = Nothing

    MsgBox "Mükerrer kayıtlar renklendirilmiştir." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...
Korhan hocam öncelikle çok teşekkür ederim yardımınız için aynı kişilerde sorunsuz çalışıyor , TC leri farklı isimleri aynı olan kayıtlarda da renklendirme yapabilirmiyiz
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
43,372
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

Alan_1 (TC No ve AD olarak kontrol eder. Dilerseniz kodun sonundaki bölümde ayrı renk verebilirsiniz.)
Alan_2 (AD olarak kontrol eder. Dilerseniz kodun sonundaki bölümde ayrı renk verebilirsiniz.)

C++: 
Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim S1 As Worksheet, Dizi_1 As Object, Dizi_2 As Object
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double
    Dim Aranan As String, Alan_1 As Range, Alan_2 As Range
    
    Zaman = Timer
    
    Set S1 = Sheets("ANA SAYFA")
    Set Dizi_1 = CreateObject("Scripting.Dictionary")
    Set Dizi_2 = CreateObject("Scripting.Dictionary")
    
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 2 Then Son = 3
    
    S1.Range("B2:C" & S1.Rows.Count).Interior.ColorIndex = xlNone
    
    Veri = S1.Range("B2:C" & Son).Value
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Aranan = Veri(X, 1) & "|" & Veri(X, 2)
            If Not Dizi_1.Exists(Aranan) Then
                Dizi_1.Add Aranan, 1
            Else
                Dizi_1.Item(Aranan) = Dizi_1.Item(Aranan) + 1
            End If
        
            Aranan = Veri(X, 2)
            If Not Dizi_2.Exists(Aranan) Then
                Dizi_2.Add Aranan, 1
            Else
                Dizi_2.Item(Aranan) = Dizi_2.Item(Aranan) + 1
            End If
        End If
    Next

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 1) & "|" & Veri(X, 2)
        If Dizi_1.Item(Aranan) > 1 Then
            If Alan_1 Is Nothing Then
                Set Alan_1 = S1.Cells(X + 1, 2).Resize(1, 2)
            Else
                Set Alan_1 = Application.Union(Alan_1, S1.Cells(X + 1, 2).Resize(1, 2))
            End If
        End If
    
        Aranan = Veri(X, 2)
        If Dizi_2.Item(Aranan) > 1 Then
            If Alan_2 Is Nothing Then
                Set Alan_2 = S1.Cells(X + 1, 3)
            Else
                Set Alan_2 = Application.Union(Alan_2, S1.Cells(X + 1, 3))
            End If
        End If
    Next
    
    If Not Alan_1 Is Nothing Then Alan_1.Interior.ColorIndex = 6
    If Not Alan_2 Is Nothing Then Alan_2.Interior.ColorIndex = 6

    Set S1 = Nothing
    Set Dizi_1 = Nothing
    Set Dizi_2 = Nothing

    MsgBox "Mükerrer kayıtlar renklendirilmiştir." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
 
M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Altın Üyelik Bitiş Tarihi
19-10-2021
Korhan Ayhan' Alıntı:
Deneyiniz.

Alan_1 (TC No ve AD olarak kontrol eder. Dilerseniz kodun sonundaki bölümde ayrı renk verebilirsiniz.)
Alan_2 (AD olarak kontrol eder. Dilerseniz kodun sonundaki bölümde ayrı renk verebilirsiniz.)

C++: 
Option Explicit

Sub Mukerrerleri_Renklendir()
    Dim S1 As Worksheet, Dizi_1 As Object, Dizi_2 As Object
    Dim Veri As Variant, Son As Long, X As Long, Zaman As Double
    Dim Aranan As String, Alan_1 As Range, Alan_2 As Range
   
    Zaman = Timer
   
    Set S1 = Sheets("ANA SAYFA")
    Set Dizi_1 = CreateObject("Scripting.Dictionary")
    Set Dizi_2 = CreateObject("Scripting.Dictionary")
   
    Son = S1.Cells(S1.Rows.Count, 2).End(3).Row
    If Son = 2 Then Son = 3
   
    S1.Range("B2:C" & S1.Rows.Count).Interior.ColorIndex = xlNone
   
    Veri = S1.Range("B2:C" & Son).Value
   
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        If Veri(X, 1) <> "" Then
            Aranan = Veri(X, 1) & "|" & Veri(X, 2)
            If Not Dizi_1.Exists(Aranan) Then
                Dizi_1.Add Aranan, 1
            Else
                Dizi_1.Item(Aranan) = Dizi_1.Item(Aranan) + 1
            End If
       
            Aranan = Veri(X, 2)
            If Not Dizi_2.Exists(Aranan) Then
                Dizi_2.Add Aranan, 1
            Else
                Dizi_2.Item(Aranan) = Dizi_2.Item(Aranan) + 1
            End If
        End If
    Next

    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Aranan = Veri(X, 1) & "|" & Veri(X, 2)
        If Dizi_1.Item(Aranan) > 1 Then
            If Alan_1 Is Nothing Then
                Set Alan_1 = S1.Cells(X + 1, 2).Resize(1, 2)
            Else
                Set Alan_1 = Application.Union(Alan_1, S1.Cells(X + 1, 2).Resize(1, 2))
            End If
        End If
   
        Aranan = Veri(X, 2)
        If Dizi_2.Item(Aranan) > 1 Then
            If Alan_2 Is Nothing Then
                Set Alan_2 = S1.Cells(X + 1, 3)
            Else
                Set Alan_2 = Application.Union(Alan_2, S1.Cells(X + 1, 3))
            End If
        End If
    Next
   
    If Not Alan_1 Is Nothing Then Alan_1.Interior.ColorIndex = 6
    If Not Alan_2 Is Nothing Then Alan_2.Interior.ColorIndex = 6

    Set S1 = Nothing
    Set Dizi_1 = Nothing
    Set Dizi_2 = Nothing

    MsgBox "Mükerrer kayıtlar renklendirilmiştir." & vbLf & vbLf & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub
Genişletmek için tıkla ...
Korhan hocam kodu yeni deneme imkanım oldu istediğim gibi çalışıyor Çok teşekkür ederim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst