Veri girişine zorlamak

[OZCANLOK]

form da aradım fakat bir kaç örnek buldum ama
kendi dosyama uyarlayamadım

veri doğrulamada sadece 1 kriter için dığrulama yapıyoruz

Ben ise 3 4 tane veri doğrulama yapmak istiyorum

Ekte dosyanın küçük bir örneğinde açıklamaya çalıştım

Yardımlarınız için şimdiden teşekkürler

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu, ilgili sayfanın kod bölümüne kopyalayınız

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [F5:F8,J5:J8,N5:N8]) Is Nothing Then
   If Cells(Target.Row, 4) < 0 Then: Target = "": Exit Sub
     If Not IsNumeric(Target.Value) Then: Target = "# HATALI #": Exit Sub
       If (Target.Value Mod 4) <> 0 Then: Target = "# HATALI #": Exit Sub
ElseIf Not Intersect(Target, [F17:F23,J17:J23,N17:N23]) Is Nothing Then
   If Cells(Target.Row, 4) < 0 Then: Target = "": Exit Sub
     If Not IsNumeric(Target.Value) Then: Target = "# HATALI #": Exit Sub
       If (Target.Value Mod 70) <> 0 Then: Target = "# HATALI #": Exit Sub
End If
End Sub

 

[OZCANLOK]

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Not Intersect(Target, [F5:F8,J5:J8,N5:N8]) Is Nothing Then
If (Target.Value Mod 4) <> 0 Then: Target = "": Exit Sub
10 MsgBox "4 veya katlarını giriniz", vbCritical + vbOKOnly

ElseIf Not Intersect(Target, [F17:F23,J17:J23,N17:N23]) Is Nothing Then
If (Target.Value Mod 70) <> 0 Then: Target = "": Exit Sub
MsgBox "70 veya katlarını giriniz", vbCritical + vbOKOnly
Application.ScreenUpdating = True
End If
End Sub

yukarıdaki kodu kendime göre düzenledim fakat doğru veri girince msbox çıkyor
bunu nasıl düzeltebiliriz. teşekkürler

 

[Ferhat Pazarçevirdi]

Eğer bu şekidle kullanacaksanız, aşağıdaki gibi düzenleyin. Ama bu kod yapısı ile, ilgili hücrelere nümerik olmayan bir değer girilirse, kodlar çuvallar ve hata verir. Target'in numeric olup olmadığını da kontrol ettirmelisiniz. Diğer taraftdan bu son düzenlenmiş kodlarınız; D sütunundaki değeri dikkate almıyor haberiniz olsun.

Private Sub Worksheet_Change(ByVal Target As Range)
'Application.ScreenUpdating = False
If Not Intersect(Target, [F5:F8,J5:J8,N5:N8]) Is Nothing Then
      If (Target.Value Mod 4) <> 0 Then: Target = "": _
          MsgBox "4 veya katlarını giriniz", vbCritical + vbOKOnly: _
             Target.Select: _
                 Exit Sub
ElseIf Not Intersect(Target, [F17:F23,J17:J23,N17:N23]) Is Nothing Then
      If (Target.Value Mod 70) <> 0 Then: Target = "": _
          MsgBox "70 veya katlarını giriniz", vbCritical + vbOKOnly: _
              Target.Select: _
                 Exit Sub
'Application.ScreenUpdating = True
End If
End Sub

 

[OZCANLOK]

evet haklısınız kodlar çuvalladı
peki kodun içine

For Each Hücre In [j17:de300]
If Not IsNumeric(Hücre) Then Hücre.Value = ""

nasıl uygularız
göndermiş olduğunuz hali ile çalışıyor

d kolonunu devre dışı bıraktım çünki makinayı yoruyor onu normal validation ile
çözdüm ilginiz için teşekkürler

Private Sub Worksheet_Change(ByVal Target As Range)
'Application.ScreenUpdating = False
If Not Intersect(Target, [F5:F8,J5:J8,N5:N8]) Is Nothing Then
If (Target.Value Mod 4) <> 0 Then: Target = "": _
MsgBox "4 veya katlarını giriniz", vbCritical + vbOKOnly: _
Target.Select: _
Exit Sub
ElseIf Not Intersect(Target, [F17:F23,J17:J23,N17:N23]) Is Nothing Then
If (Target.Value Mod 70) <> 0 Then: Target = "": _
MsgBox "70 veya katlarını giriniz", vbCritical + vbOKOnly: _
Target.Select: _
Exit Sub
'Application.ScreenUpdating = True
End If
End Sub

 

[Ferhat Pazarçevirdi]

For Each Hücre In [j17:de300]
If Not IsNumeric(Hücre) Then Hücre.Value = ""

Eğer kodda; bu döngü satırları kullanlırsa; hücrenin birine değer girdiğinizde; yaklaşık 29.000 adet hücrenin değeri numerik mi diye kontrol edilmek zorunda kalır.

Esas makinayı yoracak ve bekletecek şey bu satırlar...

Ne yapmak istediğinizi daha açık yazarsanız, uygun bir çözüm üretilir.

 

[OZCANLOK]

sn fpc söylemiş olduğunuz şey doğru o yüzden sizin
ilk vermiş olduğunuz koddaki numeric satırını kullandım makro çok güzel
çalışıyor fakat şöyle bir problem oluştu

target alanı çok olduğu için tanımlamak zaman alıyor ve bu alan
her ay değişiyor
bunu kısatmak için formda gördüğüm şekilde nasıl yapabiliriz. aşağıda açıklama
çalıştım

For x = 5 To 8
For z = 17 To 23
For y = 6 To 210 Step 3

If Not Intersect(Target, Cells(x, y)) Is Nothing Then
If Not IsNumeric(Target.Value) Then: Target = "": Exit Sub
If (Target.Value Mod 4) <> 0 Then: Target = "": _
MsgBox "4 veya katlarını giriniz", vbCritical + vbOKOnly: _
Target.Select: _
Exit Sub
ElseIf Not Intersect(Target, Cells(z, y)) Is Nothing Then
If Not IsNumeric(Target.Value) Then: Target = "": Exit Sub
If (Target.Value Mod 70) <> 0 Then: Target = "": _
MsgBox "70 veya katlarını giriniz", vbCritical + vbOKOnly: _
Target.Select: _
Exit Sub
Application.ScreenUpdating = True
End If
End Sub