aynı satırdaki mükerrere izin vermeme

[euphrates55]

m2:gf2 arasında olacak şekilde
m2 den başlayarak son dolu hücre aralığındaki hücreye 2. kere aynı veri girildiğinde uyarı verdirtmek istiyorum.
bir kodu uyarlamaya çalışsam da sürekli uyarı vermesini çözemedim...

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Intersect(Target, [m2:gf2]) Is Nothing Then Exit Sub
    say = WorksheetFunction.CountIf(Range("m2:gf2" & Target.Column), Target)
    If say > 0 Then
    MsgBox "BU KAYIT MEVCUTTUR"

    End If
    End Sub

 

[Orion1]

Kod yazmadan , Veri doğrulama ile yapabilirsiniz.

 

[euphrates55]

Kod yazmadan , Veri doğrulama ile yapabilirsiniz.

kod olursa sevinirim. öğlenden beri yapmaya çalıştım. beceremedim. öğrenmiş olurum biraz

 

[Orion1]

Böyle deneyiniz.

say = WorksheetFunction.CountIf(Range("m2:gf2"), Target)
    If say > 1 Then
    MsgBox "BU KAYIT MEVCUTTUR"
    exit sub

 

[euphrates55]

evren bey teşekkürler. keşke çok uzun bir kod olsaydı

Private Sub Worksheet_Change(ByVal Target As Range)
say = WorksheetFunction.CountIf(Range("m2:gf2"), Target)
    If say > 1 Then
    MsgBox "BU KAYIT MEVCUTTUR"
    Exit Sub
    End If
End Sub

eline sağlık

 

[Korhan Ayhan]

Ben sorunuzu M-GF aralığında her satır için ayrı ayrı bu kontrolü yapmak isiyorsunuz şeklinde anladım. Bu sebeple alternatif olarak aşağıdaki kodu hazırladım.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Say As Integer
    If Intersect(Target, Range("M2:GF" & Rows.Count)) Is Nothing Then Exit Sub
    Say = WorksheetFunction.CountIf(Range("M" & Target.Row & ":GF" & Target.Row), Target)
    If Say > 1 Then
        MsgBox "Mükerrer kayıt girdiniz!", vbCritical
        Target.ClearContents
        Target.Select
        Exit Sub
    End If
End Sub

 

[euphrates55]

evren bey doğru anlamıştı korhan ayhan. sadece başlıklarda kontrol istiyordum. başka bir kod ile çakıştı ama. hata veriyor. tek başına sizinki de dahil düzgün çalışıyor. teşekkürler

 

[euphrates55]

5 numaralı mesajdaki kod aşağıdaki kodla çakışıyor. aşağıya yazdığım kod benim için önemli olan kod. 5 numaralı mesajdaki koda müdahale şansımız varsa yardımcı olmanızı talep edeceğim.

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
UserForm2.Hide

Set gt = Sheets("GT")
Set sy = Sheets("Etiket")
sy.Range("M3:gf2000").Select

Selection.ClearContents
sy.Range("M3:gf2000").Borders.LineStyle = xlNone 'seçili alanda bordür çizgisini kaldırır

Set Sh = gt.Columns(1).Find("T", , , , xlByRows, xlPrevious) '1. sütunda son T yazan hücre

bc = sy.Range("gf2").End(1).Column  'Etiket Colon
GC = gt.Range("gf2").End(1).Column  'GT     Colon

For i = 13 To bc
   SBAS = Trim(sy.Cells(2, i).Value) 'Sayfa başlık
   c = gt.Range("A2:gf2").Find(SBAS).Column
  
           GX = gt.Cells(2, c).Address(ColumnAbsolute:=False)
           GA = Mid(GX, 1, InStr(GX, "$") - 1) & Sh.Row
           GR = gt.Range(GA).End(xlUp).Row
          
           say = 2
           For R = 3 To GR Step 6
                T = Trim(gt.Cells(R, 1).Value) 'T Mİ

                If OptionButton2 = True And T <> "T" Then GoTo DEVAMR
                
                SAYI = gt.Cells(R, c).Value 'GT SAYISI
                say = say + 1
                sy.Cells(say, i).Value = SAYI
DEVAMR:
           Next R

   '-----------------------------------
Next i

Cells(2, 13).Select ' son satırı aktif hücreden ileriye bulduğu için bunu seçtirdim.
Set shgt = sy.Range("m65536").End(xlUp) '13. sütunda son dolu hücre
Set ssat = Cells(ActiveCell.Row, 256).End(xlToLeft) '2. satırda son dolu hücre

Range(Cells(2, 13), Cells(shgt.Row, ssat.Column)).Borders.LineStyle = xlContinuous 'seçili alana bordür çizgisi koyar

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox "TAMAMLANDI", vbInformation, "FrtGNY"
End Sub

 

[Korhan Ayhan]

Kodunuzun başlangıçta "Application" ifadesi ile başlayan satırlarının altına aşağıdaki kod satırını ekleyiniz.

Application.EnableEvents = False

Yine aynı mantıkla kodunuzun bitiş bölümüne de aşağıdaki kod satırını ekleyip deneyiniz.

Application.EnableEvents = True

 

[euphrates55]

Teşekkürler @Korhan Ayhan