MÜKERER KAYIT BULMAK

Bintang

Altın Üye
Katılım
31 Ekim 2006
Mesajlar
328
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019,Türkçe
Altın Üyelik Bitiş Tarihi
05-09-2029
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ı
 

Ekli dosyalar

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Kriterlerden herhangi biri gerçekleşince mi?
Yoksa tüm kriterler gerçekleşince mi?
 

Bintang

Altın Üye
Katılım
31 Ekim 2006
Mesajlar
328
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019,Türkçe
Altın Üyelik Bitiş Tarihi
05-09-2029

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
Aşağıdaki kodları bir module içine ekleyip kullanabilirsiniz.
C++:
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

Altın Üye
Katılım
31 Ekim 2006
Mesajlar
328
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019,Türkçe
Altın Üyelik Bitiş Tarihi
05-09-2029
Aşağıdaki kodları bir module içine ekleyip kullanabilirsiniz.
C++:
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.
 

Ekli dosyalar

ÖmerFaruk

Destek Ekibi
Destek Ekibi
Katılım
22 Ekim 2017
Mesajlar
4,779
Excel Vers. ve Dili
Microsoft 365 Tr-64
If say > 1 Then

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

Bintang

Altın Üye
Katılım
31 Ekim 2006
Mesajlar
328
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019,Türkçe
Altın Üyelik Bitiş Tarihi
05-09-2029
Üstadım ilgi ve alakanız için çok teşekkür ederim.
 
Üst