• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

kopyala yapıştırda mükerrerlik kontrolü

N

numan şamil

Destek Ekibi
Destek Ekibi
Katılım
27 Ocak 2011
Mesajlar
1,238
Excel Vers. ve Dili
Ofis 2013 Türkçe
Merhabalar
Aşağıdaki kodlarda verileri tek tek girerken mükerer girildiğinde uyarıyor Ancak veriler bulunan bu sayfaya (örn: "A5:J5 arasını komple(beraraber) "C" sutunundaki mükerer veride uyarması gerekiyor) kopyala yapıştır yolu ile veri girildiğinde daha önce aynı veriler varsa uyarı verecek şekilde kodları nasıl revize edebilirim
Not: kodlar Ömer hocaya aittir

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
Dim Wf As WorksheetFunction, aLan As Range, sAy As Long
If Intersect(Target, [C:DI]) Is Nothing Then Exit Sub
Set Wf = WorksheetFunction
With Target
If .Row < 3 Or Not (.Column - 3) Mod 10 = 0 Then Exit Sub
If .Value = "" Then Exit Sub
Set aLan = Range(Cells(3, .Column), Cells(.Row, .Column))
sAy = Wf.CountIf(aLan, .Value)
If sAy > 1 Then
MsgBox .Value & " Değeri Mükerrerdir"
'.ClearContents
End If
End With
End Sub
 
Son düzenleme:
Merhaba
açıklamalı örnek dosya ekledim
İlgilenenlere teşekkür ederim
 

Ekli dosyalar

Arkadaşlar bir fikri olan yok mu?
 
Son düzenleme:
Merhaba,

Alternatif olarak aşağıdaki kodu denermisiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim X As Long, Alan As Range, Say As Long
 
    If Intersect(Target, Range("C:DI")) Is Nothing Then Exit Sub
    If Target.Row < 3 Then Exit Sub
 
    For X = Cells(Rows.Count, 3).End(3).Row To 3 Step -1
        If WorksheetFunction.CountIf(Range("C:C"), Cells(X, 3)) > 1 Then
            Say = Say + 1
            If Alan Is Nothing Then
                Set Alan = Cells(X, 3)
            Else
                Set Alan = Union(Alan, Cells(X, 3))
            End If
        End If
    Next
 
    If Say > 0 Then
        Onay = MsgBox("C sütununda mükerrer veriler tesbit edilmiştir!" & Chr(10) & _
        "Bu verilere ait satırların içeriğini temizlemek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
 
        If Onay = vbNo Then
            MsgBox "İşleminiz iptal edilmiştir."
        Else
            Alan.EntireRow.ClearContents
        End If
    End If
End Sub
 
Merhaba korhan bey ve Dragon44760 Bey
İlginize teşekkürler
Korhan Bey
kodları inceledim
Mükerrerlik kontrolü
"C","M","W","AG","AQ","BA","BK","BU","CE","CO","CY ",DI" sutunlarda bağımsız şekilde olacaktır diğer sutunlarında aynı veriler olsada herhangi işlem yapmaması gerekiyor
Yani mükerrerlik kontrolü sadece yukarıda belirttiğim sutunlarda bağımsız (kendi sutunu içerisindeki hücrede)olacaktır Bu sutunlar arasında mükerrerlik kontrolü olmayacaktırMükerrerlik kontrolü her sutunda kendisine ait hücreler arasında olacaktır.
1. nolu mesajda verdiğim Ömer Hocaya ait kodlar bu işi veriler tek tek girilirse yapıyor benim istediğim 2. nolu mesajdaki örnek dosyada olduğu gibi
çoğunlukla örn: A5:j5 arasındaki verileri kopyalayıp K7:T7 arasına yapıştırdığımda "M" sutununa denk gelen verinin aynısı "M" sutununa daha öncegirilmişse sadece uyarı vermesi silme işlemini iptal edebiliriz .Bu şart yukarıda belirttiğim sutunların hepsi için geçerli
 
Son düzenleme:
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Hücre As Range, Say As Long, Sütun As Byte
 
    If Intersect(Target, Range("C:DI")) Is Nothing Then Exit Sub
    If Target.Row < 3 Then Exit Sub
 
    If Target.Cells.Count = 1 And (Target.Column - 3) Mod 10 = 0 Then
        If WorksheetFunction.CountIf(Range(Cells(1, Target.Column), Cells(Rows.Count, Target.Column)), Target.Value) > 1 Then
            MsgBox Target & " değeri mükerrer girilmiştir!", vbCritical, "Dikkat !"
        End If
        
    Else
 
       For Each Hücre In Selection
           If (Hücre.Column - 3) Mod 10 = 0 Then
               If WorksheetFunction.CountIf(Range(Cells(1, Hücre.Column), Cells(Rows.Count, Hücre.Column)), Hücre.Value) > 1 Then
                   Say = Say + 1
               End If
           End If
       Next
    
       If Say > 0 Then
           MsgBox "Seçili alanda mükerrer veriler tesbit edilmiştir!", vbCritical, "Dikkat !"
       End If
    End If
End Sub
 
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For c = [C65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("C3:C" & c), Cells(c, "C")) > 1 Then
Onay = MsgBox("Mükerrer veri tesbit edilmiştir!" & Chr(10) & _
"Bu verilere ait satırların içeriğini temizlemek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
If Onay = vbNo Then
MsgBox "İşleminiz iptal edilmiştir."
Else
Set a = Cells(c, "C")
Set b = Cells(c, "C").Offset(0, 7)
Range(a, b).ClearContents
End If
End If
Next

For c = [M65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("M3:M" & c), Cells(c, "M")) > 1 Then
Onay = MsgBox("Mükerrer veri tesbit edilmiştir!" & Chr(10) & _
"Bu verilere ait satırların içeriğini temizlemek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
If Onay = vbNo Then
MsgBox "İşleminiz iptal edilmiştir."
Else
Set a = Cells(c, "M")
Set b = Cells(c, "M").Offset(0, 7)
Range(a, b).ClearContents
End If
End If
Next

End Sub
Ben de kendimce tarzanca bir şeyler hazırladım ama Korhan hocamınki gayet güzel olmuş...
Sadece "C" ve "M" sürunlarına uyguladım eğer kullanmak isterseniz diğer sütunlara uygularsınız...
 
Korhan Bey
Çok teşekkür ederim
İstediğm gibi oldu.
İyi çalışmalar
 
dragon44760' Alıntı:
Kod: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
For c = [C65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("C3:C" & c), Cells(c, "C")) > 1 Then
Onay = MsgBox("Mükerrer veri tesbit edilmiştir!" & Chr(10) & _
"Bu verilere ait satırların içeriğini temizlemek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
If Onay = vbNo Then
MsgBox "İşleminiz iptal edilmiştir."
Else
Set a = Cells(c, "C")
Set b = Cells(c, "C").Offset(0, 7)
Range(a, b).ClearContents
End If
End If
Next

For c = [M65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("M3:M" & c), Cells(c, "M")) > 1 Then
Onay = MsgBox("Mükerrer veri tesbit edilmiştir!" & Chr(10) & _
"Bu verilere ait satırların içeriğini temizlemek istiyor musunuz?", vbCritical + vbYesNo, "Dikkat !")
If Onay = vbNo Then
MsgBox "İşleminiz iptal edilmiştir."
Else
Set a = Cells(c, "M")
Set b = Cells(c, "M").Offset(0, 7)
Range(a, b).ClearContents
End If
End If
Next

End Sub
Ben de kendimce tarzanca bir şeyler hazırladım ama Korhan hocamınki gayet güzel olmuş...
Sadece "C" ve "M" sürunlarına uyguladım eğer kullanmak isterseniz diğer sütunlara uygularsınız...
Genişletmek için tıkla ...

İlgilendiğiniz için teşekkürler
hiçbir emek boşa gitmez kodlarınızı arşivime aldım
iyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst