MÜKERER KAYIT BULMAK

[Bintang]

Merhaba; Yapmak İstediğim Mükerrer Kayıtları Bulmak
Bunu Tespit Edebilmek İçin Koymak İstediğim Kriterler Şunlardır.

1. Tutar Benzerliği
2. DĞ/…/ dan Sonraki Yapılan Açıklamanın Benzerliği
Örnek DĞ/7509/79133 NL.FT.NIZ/ BİL-PA GIDA
3. Yapılan Açıklamanın Benzerliği
Örnek S03523 NL.FT.NIZ/ SALKİM KAĞIT SANAYİ x 30.627,74$
4. Tarih Benzerliği
5. Mükerrer Kayıt Var İse Satırı Boydan Boya Kırmızıya Boyaması

 

[ÖmerFaruk]

Kriterlerden herhangi biri gerçekleşince mi?
Yoksa tüm kriterler gerçekleşince mi?

 

[Bintang]

Kriterlerden herhangi biri gerçekleşince mi?
Yoksa tüm kriterler gerçekleşince mi?

Üstadım Merhaba;
Kriterlerden en az ikisi gerçekleşmesi yeterli diye düşünüyorum

 

[ÖmerFaruk]

Aşağıdaki kodları bir module içine ekleyip kullanabilirsiniz.

Sub SatırRenklendir()
    say = WorksheetFunction.CountA(Range("A3:A19")) + 2
    If say < 3 Then say = 3
    Range("A3:F19").Interior.Color = xlNone
    Veri = Range("A3:F" & say).Value
    For i = LBound(Veri) To UBound(Veri) - 1
        If Veri(i, 1) = "" Then GoTo Devam
        If Left(Veri(i, 5), 3) = "DĞ/" Then
            Ara = Mid(Veri(i, 5), 1 + InStr(4, Veri(i, 5), "/"), 999)
        Else
            Ara = Veri(i, 5)
        End If
        For k = i + 1 To UBound(Veri)
            say = 0
            If Veri(i, 6) = Veri(k, 6) Then say = say + 1
            If Left(Veri(k, 5), 3) = "DĞ/" Then
                Bak = Mid(Veri(k, 5), 1 + InStr(4, Veri(k, 5), "/"), 999)
            Else
                Bak = Veri(k, 5)
            End If
            If Ara = Bak Then say = say + 1
            If Veri(i, 2) = Veri(k, 2) Then say = say + 1
            
            If say > 1 Then
                Range("A" & i + 2).Resize(1, 6).Interior.Color = RGB(255, 0, 0)
                Range("A" & k + 2).Resize(1, 6).Interior.Color = RGB(255, 0, 0)
            End If

        Next k
Devam:
    Next i
End Sub

 

[Bintang]

Aşağıdaki kodları bir module içine ekleyip kullanabilirsiniz.

Sub SatırRenklendir()
    say = WorksheetFunction.CountA(Range("A3:A19")) + 2
    If say < 3 Then say = 3
    Range("A3:F19").Interior.Color = xlNone
    Veri = Range("A3:F" & say).Value
    For i = LBound(Veri) To UBound(Veri) - 1
        If Veri(i, 1) = "" Then GoTo Devam
        If Left(Veri(i, 5), 3) = "DĞ/" Then
            Ara = Mid(Veri(i, 5), 1 + InStr(4, Veri(i, 5), "/"), 999)
        Else
            Ara = Veri(i, 5)
        End If
        For k = i + 1 To UBound(Veri)
            say = 0
            If Veri(i, 6) = Veri(k, 6) Then say = say + 1
            If Left(Veri(k, 5), 3) = "DĞ/" Then
                Bak = Mid(Veri(k, 5), 1 + InStr(4, Veri(k, 5), "/"), 999)
            Else
                Bak = Veri(k, 5)
            End If
            If Ara = Bak Then say = say + 1
            If Veri(i, 2) = Veri(k, 2) Then say = say + 1
           
            If say > 1 Then
                Range("A" & i + 2).Resize(1, 6).Interior.Color = RGB(255, 0, 0)
                Range("A" & k + 2).Resize(1, 6).Interior.Color = RGB(255, 0, 0)
            End If

        Next k
Devam:
    Next i
End Sub

Üstadım ilk önce ilgi ve alakanızdan dolayı çok teşekkür ederim. Hemen modüle kayıt ettim ve çalıştırdım. Ancak şöyle bir problem ile karşılaştım.
Kriterlerden en az ikisinin karşılaştırılması başka bir soruna sebep oldu aynı fatura da % 1 KDV li açıklama ile % 8 KDV açıklamayı karşılaştırdığı için ve tarihte aynı olduğu için liste de bir çok kırmızı oldu. Eğer ki kriterleri 3 e çıkarma ihtimali olursa dosya daha kullanışlı olacak diye düşünüyorum. Bana bu konuda yardımcı olursanız inanın çok sevinirim. Örnek dosya eke koyuyorum.

 

[ÖmerFaruk]

If say > 1 Then

kodlarıda bu satırı bulup 1 yerine 2 yazın.

 

[Bintang]

Üstadım ilgi ve alakanız için çok teşekkür ederim.