tüm hücreleri aynı olan mükerrer satırların bulunması

[p_rens]

Şu ana kadar aradığım tüm mükerrer kayıtlarla ilili olan problemlerde sadece bir sutundaki bilgilere bakılarak yapılmış. a stunundaki bilgiler çiftse boyanmış- silinmiş vs. ama 2 veya daha fazla hücre aynı ise şeklinde bir çözüm bulamadım.

Oysa benim aradığım abone listesinde abone ad soyad adres vd. bilgilerin tamamı aynı ise yani tüm satır aynı ise bu hücreleri renklendirmesi.

yardımlarınızı bekliyorum.
örn. dosya ekte.

 

[metinozlu]

hücre birleştir yöntemiyle yapılmış çözüm ektedir,

 

[p_rens]

hücre birleştir yöntemiyle yapılmış çözüm ektedir,

Bu şekilde işin içinden yine çıkamam. birleşmiş hücreleri okumak bile zor.

Daha önce mükerrer kayıtların silinmesi için KORHAN AYHAN tarafından bir formül yapıldı. formül aşağıda bunun üzerinde nasıl bir düzeltme yapalım ki mükerrer kayıtları silmesin boyasın.

Sub MÜKERRER_OLANLARI_SİL()
Application.ScreenUpdating = False
[IV:IV].Clear
With Range("IV2:IV" & [B65536].End(3).Row)
.Formula = "=B2&C2&D2&E2&F2&G2&H2&I2&J2&K2&L2&M2&N2&O2&P2&Q2&R2&S2&T2&U2&V2&W2&X2&Y2&Z2&AA2&AB2"
.Value = .Value
End With
For X = [IV65536].End(3).Row To 2 Step -1
If WorksheetFunction.CountIf(Range("IV2:IV" & X), Cells(X, "IV")) > 1 Then Rows(X).Delete
Next
[IV:IV].Clear
Application.ScreenUpdating = True
MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub

 

[veyselemre]

Kodları bir module ekleyin deneyin.

Sub dene()
    ason = [a65536].End(3).Row
    Range(Cells(2, "A"), Cells(ason, "I")).Interior.ColorIndex = -4142
    renkler = Array(3, 4, 5, 6, 7, 8, 10, 14, 15, 17, 19, 20, 22, 23, 24, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 47, 48)
    For x = 2 To ason - 1
        If Cells(x, 1) <> "" And Cells(x, 1).Interior.ColorIndex = -4142 Then
            a1 = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Range(Cells(x, "A"), Cells(x, "I")).Value)), "~")
            bulundu = False
            renk = renkler(renkIdx)
            For y = x + 1 To ason
                If Cells(y, 1) <> "" And Cells(y, 1).Interior.ColorIndex = -4142 Then
                    a2 = Join(WorksheetFunction.Transpose(WorksheetFunction.Transpose(Range(Cells(y, "A"), Cells(y, "I")).Value)), "~")
                    If a1 = a2 Then
                        bulundu = True
                        Range(Cells(y, "A"), Cells(y, "I")).Interior.ColorIndex = renk
                    End If
                End If
            Next y
            If bulundu Then
                Range(Cells(x, "A"), Cells(x, "I")).Interior.ColorIndex = renk
                renkIdx = renkIdx + 1
                If renkIdx > UBound(renkler) Then renkIdx = 0
            End If
        End If
    Next x
End Sub

 

[p_rens]

veyselemre kardeşim formül 10 satırlı olan denemede çalıştı fakat 1950 satırlı asıl dosyamda 5 dk.dır hala işlem yapmaya çalışıyor. ve sonunda dosyayı kilitledi. eğer renkler den böyle yapıyorsa tek renk de kullanabiliriz.

malesef olmadı. yinede ilginizden dolayı tşk. ederim.

 

[Orion1]

J ve K sütunlarına formüller uygulandı.
A:I aralığınada koşullu biçimlendirme uygulandı.
Mükerrer kayıtlar kırmızı dolgu renkli fontlarda sarı ve italik oluyor.
Ekli dosyayı inceleyiniz.:xool:

 

[veyselemre]

Aşağıdaki kodlar daha hızlı çalışıyor.

Sub mukerrerSatirlariFarkliRenklerdeIsaretle()
    Application.ScreenUpdating = False

    With Range(Cells(1, "A"), Cells([a65536].End(3).Row, "I"))
        .Interior.ColorIndex = -4142
        a = .Value
    End With

    With CreateObject("Scripting.Dictionary")
        .CompareMode = vbTextCompare
        For i = 2 To UBound(a, 1)
            z = a(i, 1)
            For t = 2 To 9: z = z & "~" & a(i, t): Next

            If Not .exists(z) Then
                ReDim w(0)
                w(0) = i
                .Add z, w
            Else
                w = .Item(z)
                ReDim Preserve w(0 To UBound(w) + 1)
                w(UBound(w)) = i
                .Item(z) = w
            End If
        Next
        w = .items
    End With

    renkler = Array(3, 4, 5, 6, 7, 8, 10, 14, 15, 17, 19, 20, 22, 23, 24, 35, 36, 37, 38, 39, 40, 42, 43, 44, 45, 46, 47, 48)

    For i = 0 To UBound(w)
        If UBound(w(i)) > 0 Then
            renk = renkler(t)
            For Each sat In w(i)
                Intersect(Rows(sat), [A:I]).Interior.ColorIndex = renk
            Next
            t = t + 1
            If t > UBound(renkler) Then t = 0
        End If
    Next i

    Erase w, a, renkler
    Application.ScreenUpdating = True

End Sub