mükerreri bulurken boşluktan sonrasını dikkate almama

[sdegirmenci]

Merhaba;
Ekteki dosyamda mükerrer kaydı bulan bir kod mevcut ancak dosyam üzerinde açıkladığım gibi boşluktan sonra yazılanları dikkate almaması gerekiyor. İnceleyebilirseniz sevinirim. Saygılarımla

 

[janveljan]

Worksheet change kodlarında

say = WorksheetFunction.CountIf(Range("F5:F" & Target.Row - 1), Target)

yerine

    If InStr(1, Target, " ") > 0 Then
        deger = Left(Target, InStr(1, Target, " ") - 1)
    Else
        deger = Target
    End If
    For i = 5 To Target.Row-1
        If InStr(1, Cells(i, "F"), deger) > 0 Then say = say + 1
    Next

kodlarını kullanırsınız olur zannediyorum, biraz daha yavaş çalışacaktır.


Ancak 2007/330 var iken 2007/33 ü mükerrer olarak görecektir.

 

[sdegirmenci]

Sayın janveljan;
İlginize teşekkür ediyorum,Bu şekildede kullanılabilir, keşke sıfırı yok kabul etmeseydi daha iyi olurdu, ama olmuyorsa bu şekilde de olur.İşleriniz kolay gelsin

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak aşağıdaki kodu kullanırsanız kayıt sayınız arttıkça hız bakımından kayıba uğramazsınız.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
 
    If Intersect(Target, [F:F,H3]) Is Nothing Then Exit Sub
    If Target.Column = 8 Then
        TextBox4.Value = Target.Value
    Exit Sub
    End If
 
    If InStr(1, Target, " ") > 0 Then
    Dosya_No = Mid(Target, 1, InStr(1, Target, " ") - 1)
    Else
    Dosya_No = Target
    End If
 
    Say = WorksheetFunction.CountIf(Range("F5:F" & Target.Row - 1), Dosya_No)
 
    If Say > 0 Then
    MsgBox "BU KAYIT MEVCUTTUR !"
    End If
End Sub

 

[sdegirmenci]

Sayın Korhan Ayhan Hocam;
İlginize çok teşekkür ederim,Kodu kopyaladım kusursuz çalışmakta, işleriniz kolay gelsin. Hoşçakalın

 

[janveljan]

Sayın janveljan;
İlginize teşekkür ediyorum,Bu şekildede kullanılabilir, keşke sıfırı yok kabul etmeseydi daha iyi olurdu, ama olmuyorsa bu şekilde de olur.İşleriniz kolay gelsin

Kodlar sıfırı yok saymıyor, örnek olarak 2007/336 daha önce gelmiş ise 2007/33 geldiğinde mükerrer kayıt olarak görür çünkü 2007/33 2007/336 nın içinde vardır, aynı şekilde 2007/3356787 varsa da mükerrer gözükür.

Ayrıca yanlış görmedi isem Korhan beyin kodu 2008/1085 kaydının ardından 2008/1085 E gibi bir kayıt gelirse doğru çalışır ancak ilk kayıt 2008/1085 E olupta daha sonradan 2008/1085 veya 2008/1085 A gibi kayıt gelirse yanlış sonuç verir.

 

[Korhan Ayhan]

Selamlar,

Sn. janveljan,

Doğru bir tesbitte bulunmuşsunuz. Eğer belirttiğiniz yönde kontrol talep edilirse FIND komutu ile hızlı çalışacak bir yöntem geliştirebiliriz.

 

[janveljan]

Kodları düzenledim. Bu haliyle daha önce bahsettiğim durumla karşılaşmıyoruz.

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [F:F,H3]) Is Nothing Then Exit Sub
    If Target.Column = 8 Then
        TextBox4.Value = Target.Value
        Exit Sub
    End If
    If InStr(1, Target, " ") > 0 Then
        deger = Left(Target, InStr(1, Target, " "))
    Else
        deger = Target & " "
    End If
    For i = 5 To Target.Row - 1
        If InStr(1, Cells(i, "F") & " ", deger) > 0 Then say = say + 1
    Next
    If say > 0 Then
        MsgBox "BU KAYIT MEVCUTTUR"
        Target.Select
    End If
End Sub

 

[sdegirmenci]

Sayın janveljan ve Korhan Ayhan Hocalarım;
Her ikinizede ilginizden dolayı teşekkür ederim.Son yazılan Kodu uyguladım, şu anda hatasız çalışıyor, kayıtlar çoğaldığında yavaşlarmı bilmiyorum Ellerinize sağlık.Hoşçakalın

 

[Korhan Ayhan]

Selamlar,

Alternatif olarak FIND komutu ile hazırladığım koduda kullanabilirsiniz. Kayıt sayısı arttıkça döngü ile arama yapmak zaman kaybına yol açacaktır. Fakat kayıt sayınız az olacaksa bu zaman kaybını farketmezsiniz. İncelermisiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim DOSYA_NO As String, BUL As Range, ADRES As String, VERİ As String, SAY As Integer
    
    On Error Resume Next
 
    If Intersect(Target, [F:F,H3]) Is Nothing Then Exit Sub
    If Target.Column = 8 Then
        TextBox4.Value = Target.Value
    Exit Sub
    End If
 
    If InStr(1, Target, " ") > 0 Then
        DOSYA_NO = Mid(Target, 1, InStr(1, Target, " ") - 1)
        Else
        DOSYA_NO = Target
    End If
 
    Set BUL = Range("F5:F65536").Find(DOSYA_NO)
    If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
        
        If InStr(1, Range(BUL.Address), " ") > 0 Then
        VERİ = Mid(Range(BUL.Address), 1, InStr(1, Range(BUL.Address), " ") - 1)
        End If
        
        If BUL.Row <> Target.Row And (VERİ = Target Or Range(BUL.Address) = DOSYA_NO) Then SAY = SAY + 1
        If SAY > 0 Then Exit Do
                
        Set BUL = Range("F5:F65536").FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
    End If
    
    If SAY > 0 Then MsgBox "BU KAYIT MEVCUTTUR !", vbCritical, "MÜKERRER KAYIT"
End Sub