İki Liste Karşılaştırma {6 Farklı Mükerrer Bulma}

[unilll]

Çok sağolun..
Hepsini denedim fakat 2 ve 3. kodlarda yanlarına rakamlar yazıyor. Sebebi nedir?
Bir de E sütununu da kontrol ediyor A, B, C ve D sütunları yeterli benim için

http://www.filebig.net/files/thLjaNwJdV

 

[halit3]

kodun bu bölümünü bul kırmızı yerleri E yerine D yap
Range("A2:E" & Rows.Count).Interior.ColorIndex = xlNone


Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = say
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = say

Diğer taraftan sayılar mükerrer satırları göstermektedir.

 

[unilll]

kodun bu bölümünü bul kırmızı yerleri E yerine D yap
Range("A2:E" & Rows.Count).Interior.ColorIndex = xlNone


Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = say
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = say

Diğer taraftan sayılar mükerrer satırları göstermektedir.

Değiştirdim fakat herhangi bir değişiklik olmadı

 

[halit3]

Mutlaka değişiklik olmuştur
önce bunu değişturun
Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = say
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = say

kodu çalıştırın
sonra bunu değiştirin

Range("A2:E" & Rows.Count).Interior.ColorIndex = xlNone

 

[unilll]

Mutlaka değişiklik olmuştur
önce bunu değişturun
Range(Cells(j, "A"), Cells(j, "e")).Interior.ColorIndex = say
Range(Cells(i, "A"), Cells(i, "e")).Interior.ColorIndex = say

kodu çalıştırın
sonra bunu değiştirin

Range("A2:E" & Rows.Count).Interior.ColorIndex = xlNone

Şimdi düzeldi. Çok teşekkür ediyorum..

 

[halit3]

İyi çalışmalar

 

[unilll]

İyi çalışmalar

Bu kodda ilgili herhangi bir satır limiti yok di mi? Yaklaşık 5000 satırlık veri içeren bir sayfada kodu çalıştırıyorum., excel donup kalıyor.

Yardımcı olabilir misiniz lütfen.

 

[halit3]

Renklendirmeleri iptal ettim siz dosyanızdaki renklendirmeleri manuel olarak kaldırın ve bu kodu çalıştırın
kod L sütununa mükerrer olan satırları listeliyor.

Sub mukerrer()

With Application
.Calculation = xlManual
.ScreenUpdating = False
End With

Range("J2:j" & Rows.Count).ClearContents
son = Cells(Rows.Count, "b").End(3).Row
ReDim ara1(son): ReDim ara2(son)

For t = 2 To son
ara1(t) = Cells(t, "A") & Cells(t, "B") & Cells(t, "C") & Cells(t, "D")
ara2(t) = 1
Next

For i = 2 To son

veri = ""
For j = 2 To son
bulunan = Cells(j, "A") & Cells(j, "B") & Cells(j, "C") & Cells(j, "D")

If ara2(j) = 1 Then
If ara1(i) = bulunan Then
veri = veri & "_" & j
sat = sat + 1
If sat > 1 Then
ara2(j) = 0
End If
End If
End If

Next j

deg1 = Split(Mid(veri, 2, Len(veri) - 1), "_")
If UBound(deg1) > 0 Then
For k = 0 To UBound(deg1)
Cells(deg1(k), "j") = Mid(veri, 2, Len(veri) - 1)
Next k
End If
sat = 0
Next i

With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
End With
MsgBox "işlem tamam"
End Sub

 

[Ziynettin]

Çok sağolun..
Hepsini denedim fakat 2 ve 3. kodlarda yanlarına rakamlar yazıyor. Sebebi nedir?
Bir de E sütununu da kontrol ediyor A, B, C ve D sütunları yeterli benim için

http://www.filebig.net/files/thLjaNwJdV

Sub renk_ver()
Z = TimeValue(Now)
Application.ScreenUpdating = False
Set alan = Range("A2:A" & Cells(Rows.Count, 1).End(3).Row)
alan.Resize(, 5).Interior.ColorIndex = xlNone
a = alan.Resize(, 4).Value
Set dic = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
    krt = ""
    For j = 1 To UBound(a, 2)
        krt = krt & "|" & a(i, j)
    Next j
    dic(krt) = dic(krt) + 1
Next i
renk = Array(1, 2, 3, 4, 6, 7, 8, 14, 15, 17, 20, 22, 24, 26, 27, 28, 33, _
            34, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 50, 53)
For i = 1 To UBound(a)
    krt = ""
    For j = 1 To UBound(a, 2)
        krt = krt & "|" & a(i, j)
   Next j
        If dic(krt) > 1 Then
            no = Application.Match(krt, dic.Keys, 0) Mod (UBound(renk))
            Cells(i + 1, 1).Resize(, 5).Interior.ColorIndex = renk(no)
            Cells(i + 1, 9) = renk(no)
        End If
Next i
Application.ScreenUpdating = True
MsgBox "İşlem tamam.", vbInformation
End Sub