mükerrer veri girişi

[Yesilyurtlu]

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E6:E200]) Is Nothing Then Exit Sub
On Error Resume Next
If Target.Value > 20 Then Target.Offset(0, 1).Value = Target.Value - 20
If Target.Value > 20 Then Target.Offset(0, 2).Value = Target.Value - Target.Offset(0, 1).Value
If IsNumeric(Target.Value) Then Target.Offset(0, 4).Value = Target.Value / 118 * 100
If IsNumeric(Target.Value) Then Target.Offset(0, 3).Value = Target.Value / 118 * 100 * 0.00825
If Target.Value < 20 Then Target.Offset(0, 2).Value = Target.Value
'If Target.Value <> 20 Then Target.Offset(0, 4).Value = Target.Value - Target.Value * (86.35 / 100)
'If Target.Value <> 20 Then Target.Offset(0, 5).Value = Target.Value - Target.Value * (88.58 / 100)
'If Target.Value < 20 Then Target.Offset(0, 4).Value = Target.Value - Target.Offset(0, 3).Value
Range("C6:I200").Sort Key1:=Range("C6"), Order1:=xlAscending


koda ek olarak
C6: C200
D6: D200
E6: E200 sütunlarına grilen veri aynı ise MÜKERRER VERİ GİRİŞİ VAR
Devam edeyim mi? diye sormasını EVET dersem mükerrer veriyi yok sayıp kayıt edecek HAYIR dersem silecek bir kod istiyorum. Yardımcı olabilir misiniz?

 

[Ömer]

koda ek olarak
C6: C200
D6: D200
E6: E200 sütunlarına grilen veri aynı ise MÜKERRER VERİ GİRİŞİ VAR
Devam edeyim mi? diye sormasını EVET dersem mükerrer veriyi yok sayıp kayıt edecek HAYIR dersem silecek bir kod istiyorum. Yardımcı olabilir misiniz?

Merhaba,

Kodları aşağıdakilerle değiştirin.

Private Sub Worksheet_Change(ByVal Target As Range)
 
    Dim Wf As WorksheetFunction, say As Long, onay As String
 
    If Intersect(Target, [C6:E200]) Is Nothing Then Exit Sub
 
    Set Wf = WorksheetFunction
    On Error Resume Next
 
    With Target
        If .Value = "" Then Exit Sub
        say = Wf.CountIf(Range(Cells(6, .Column), Cells(200, .Column)), .Value)
        If say > 1 Then
            onay = MsgBox("Mükerrer Giriş/Devam mı?.", vbCritical + vbYesNo, "Dikkat!")
            If onay = vbNo Then
                .ClearContents
                Exit Sub
            End If
        End If
        If .Column = 5 Then
            If .Value >= 20 Then
                .Offset(0, 1) = .Value - 20
                .Offset(0, 2) = .Value - .Offset(0, 1)
            End If
            If IsNumeric(.Value) Then
                .Offset(0, 4) = .Value / 118 * 100
                .Offset(0, 3) = .Value / 118 * 100 * 0.00825
            End If
            If .Value < 20 Then .Offset(0, 2) = .Value
        End If
        Range("C6:I200").Sort Range("C6")
    End With
 
End Sub

.

 

[Yesilyurtlu]

Ömer abi
Ellerine sağlık Teşekkür ederim