Soru Mükerrer kontrol et, kenarlık ekle ve sıra numarası ver

[sirkülasyon]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sayfa As Worksheet
    Dim Başlangıcsatırı As Long
    Dim sonSatır As Long
    Dim i As Long
    Set sayfa = ThisWorkbook.Sheets("Lüzum_Müzekkeresi")
    Başlangıcsatırı = 10
    If Not Intersect(Target, sayfa.Range("C:E")) Is Nothing Then
        sonSatır = sayfa.Cells(sayfa.Rows.Count, "C").End(xlUp).row
        For i = Başlangıcsatırı To sonSatır
            If sayfa.Cells(i, "C").value = sayfa.Cells(i, "C").value And _
               sayfa.Cells(i, "D").value = sayfa.Cells(i, "D").value And _
               sayfa.Cells(i, "E").value = sayfa.Cells(i, "E").value Then
            
                MsgBox "Mükerrer veri girişi mevcut", vbExclamation
                sayfa.Range("B:E").Rows(i).ClearContents
                Exit For
            End If
        Next i
        For i = Başlangıcsatırı To sonSatır
            If Not IsEmpty(sayfa.Cells(i, "C").value) And _
               Not IsEmpty(sayfa.Cells(i, "D").value) And _
               Not IsEmpty(sayfa.Cells(i, "E").value) Then
                sayfa.Range("B:E").Rows(i).Borders.LineStyle = xlContinuous
            End If
        Next i
        For i = Başlangıcsatırı To sonSatır
            If Not IsEmpty(sayfa.Cells(i, "C").value) Then
                sayfa.Cells(i, "B").value = i - Başlangıcsatırı + 1
            End If
        Next i
    End If
End Sub

C,D,E satırına veri girişi yapıldıktan sonra Mükerrer veri girişi var ise mükerrer veri girişi yapılan satırda uyarı vererek silecek.
Mükerrer girişi yok ise B:E satırına kenarlık ekleyecek son olarak ta B sütununa sıra numarası verecek.
Ancak sürekli mükerrer uyarısı alıyorum.
Rica etsem yardımcı olabilir misiniz?

 

[Muzaffer Ali]

Merhaba.

sayfa.Cells(i, "C").value = sayfa.Cells(i, "C").value

satırlarını

sayfa.Cells(i, "C").value = sayfa.Cells(target.row, "C").value

şeklinde değiştir.

 

[sirkülasyon]

Değiştirdim de istediğim sonucu alamadım.
sayfa.Range("B:E").Rows(i).ClearContents kısmı hata veriyor.
o kısmı engellediğimizde de sürekli mükerrer uyarısı veriyor

 

[Erkan Akayay]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sayfa As Worksheet, dict As Object, hucre As Range, eslesme As String
    Dim baslangicSatiri As Long, sonSatir As Long, i As Long

    Set sayfa = ThisWorkbook.Sheets("Lüzum_Müzekkeresi")
    baslangicSatiri = 10
    sonSatir = sayfa.Cells(sayfa.Rows.Count, "C").End(xlUp).Row
    Set dict = CreateObject("Scripting.Dictionary")
    
    If Not Intersect(Target, sayfa.Range("C:E")) Is Nothing Then
        Application.EnableEvents = False
        
        For i = baslangicSatiri To sonSatir
            If Not IsEmpty(sayfa.Cells(i, "C").Value) And _
               Not IsEmpty(sayfa.Cells(i, "D").Value) And _
               Not IsEmpty(sayfa.Cells(i, "E").Value) Then
               
                Set hucre = sayfa.Cells(i, "C")
                eslesme = sayfa.Cells(i, "C").Value & sayfa.Cells(i, "D").Value & sayfa.Cells(i, "E").Value
                
                If dict.Exists(eslesme) Then
                    MsgBox "Mükerrer veri girişi mevcut", vbExclamation
                    sayfa.Range("B" & i & ":E" & i).ClearContents
                Else
                    dict(eslesme) = 1
                    sayfa.Range("B" & i & ":E" & i).Borders.LineStyle = xlContinuous
                    sayfa.Cells(i, "B").Value = i + 1 - baslangicSatiri
                End If
            End If
        Next i
        
        Application.EnableEvents = True
    End If
End Sub

 

[MusaPEKEL]

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim sayfa As Worksheet
    Dim Başlangıcsatırı As Long
    Dim sonSatır As Long
    Dim i As Long
    Dim mükerrer As Boolean

    Set sayfa = ThisWorkbook.Sheets("Lüzum_Müzekkeresi")
    Başlangıcsatırı = 10

    If Not Intersect(Target, sayfa.Range("C:E")) Is Nothing Then
        sonSatır = sayfa.Cells(sayfa.Rows.Count, "C").End(xlUp).Row

        For i = Başlangıcsatırı To sonSatır
            If Not IsEmpty(sayfa.Cells(i, "C").Value) And _
               Not IsEmpty(sayfa.Cells(i, "D").Value) And _
               Not IsEmpty(sayfa.Cells(i, "E").Value) Then

                
                mükerrer = False
                For j = Başlangıcsatırı To sonSatır
                    If i <> j And _
                       sayfa.Cells(i, "C").Value = sayfa.Cells(j, "C").Value And _
                       sayfa.Cells(i, "D").Value = sayfa.Cells(j, "D").Value And _
                       sayfa.Cells(i, "E").Value = sayfa.Cells(j, "E").Value Then

                        MsgBox "Mükerrer veri girişi mevcut", vbExclamation
                        sayfa.Range("B:E").Rows(i).ClearContents
                        mükerrer = True
                        Exit For
                    End If
                Next j

              
                If Not mükerrer Then
                    sayfa.Range("B:E").Rows(i).Borders.LineStyle = xlContinuous
                    sayfa.Cells(i, "B").Value = i - Başlangıcsatırı + 1
                End If
            End If
        Next i
    End If
End Sub