Sayfa içinde Koşullu hücre kopyalama

[bebar]

Merhaba,

("A3:A20") Satır aralığına rakam girdiğimde ("J3:J20") alanına aynı satır karşığında gelmesini istiyorum fakat 2 koşulum var .

* 18 den büyük bir rakam girersem yazmasın sayı büyük desin

* aynı sayıdan tekrar yazamak istersem yazmasın uyarı versin

Aşağıdaki gibi bir kod yazdım fakat tam anlamıyla olmuyor yardımcı olursanız memnun olurum. Dosyam ektedir.

Teşekkür ederim.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s3 As Worksheet
Set s3 = Sheets("Sayfa1")
If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
If Intersect(Target, s3.Range("A3:A20")) Is Nothing Then Exit Sub
On Error Resume Next
    Application.ScreenUpdating = False
For i = 3 To 20
    If Target.Value = s3.Cells(i, 10) Then
            MsgBox " Aynı değer giremezsiniz !!!", vbInformation
            s3.Cells(i, 10) = ""
            Exit For
        Else
    If Target.Value > 18 Then
            s3.Cells(Target.Row, 10) = ""
            MsgBox "18'den büyük değer giremezsiniz o kadar alan yok !!!", vbInformation
        Else
    If Target.Value <> "" Then
            s3.Cells(Target.Row, 10) = Target.Value
        Else
            s3.Cells(Target.Row, 10) = ""
        End If
        End If
        End If
    Next i
        Application.ScreenUpdating = True
End Sub

 

[turist]

Aşağıdaki şekilde deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim s3 As Worksheet
Set s3 = Sheets("Sayfa1")
If Application.CutCopyMode = xlCopy Or Application.CutCopyMode = xlCut Then Exit Sub
If Intersect(Target, s3.Range("A3:A20")) Is Nothing Then Exit Sub
On Error Resume Next
If Target.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    sy = Application.WorksheetFunction.CountIf(s3.Range("j3:j20"), Target.Value)
    If Target.Value > 18 Then
    Target = ""
            MsgBox "18'den büyük değer giremezsiniz o kadar alan yok !!!", vbInformation
Exit Sub
    End If
If sy > 0 Then
Target = ""
MsgBox "Aynı değeri giremezsiniz !!!", vbInformation
Exit Sub
End If
If Target.Value = "" Then
s3.Cells(Target.Row, 10) = ""
End If
If Target.Value <= 18 And Target.Value > 0 And Application.CountIf(s3.Range("j3:j20"), Target.Value) = 0 Then
s3.Cells(Target.Row, 10) = Target.Value
End If
 Application.ScreenUpdating = True
End Sub

 

[bebar]

Hocam çok teşekkür ederim çok faydası oldu.

 

[turist]

Hocam çok teşekkür ederim çok faydası oldu.

Sağ olun.