Veri doğrulama makro ile

[burhancavus61]

C3:AG3 aralığına herhangi bir veri girişi yaptığımda (F harfine bağlı hesaplama ama değişken olabilir) AK3 hücresindeki değere göre (örnek 270) "süre aşımı yaptınız" gibi bir uyarı almak istiyorum. Veri doğrulama ile C3:AG3 aralığında değerler kullandığım için bunu makro ile yapmak istiyorum. Bu işlemi aşağı doğru her satırda kontrol ederek devam etmem gerek. Örnek dosya ekledim yardımlarınız için teşekkür ederim.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Cell As Range
    
    If Intersect(Target, Range("C3:AG" & Rows.Count)) Is Nothing Then Exit Sub
    
    For Each My_Cell In Intersect(Target, Range("C3:AG" & Rows.Count))
        If My_Cell.Value = "F" Then
            If Cells(My_Cell.Row, "AK").Value > 270 Then
                MsgBox "Sınırı aştınız!", vbCritical
                My_Cell.ClearContents
            End If
        End If
    Next
End Sub

 

[burhancavus61]

Hocam sağol işimi gördü üzerinde ilave yaparak çoğaltacağım süpersiniz

 

[burhancavus61]

Hocam harf küçük büyük harf duyarlı yapmam için ne yapmalıyım

 

[Korhan Ayhan]

Şu anki haliyle büyük-küçük harf duyarlı olmaı gerekiyor.

Yani "F" yerine "f" yazarsanız dikkate almaz.

Duyarsız olması gerekir ki hem "f" hem de "F" harfini dikkate alsın.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Cell As Range
    
    If Intersect(Target, Range("C3:AG" & Rows.Count)) Is Nothing Then Exit Sub
    
    For Each My_Cell In Intersect(Target, Range("C3:AG" & Rows.Count))
        If UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ")) = "F" Then
            If Cells(My_Cell.Row, "AK").Value > 270 Then
                MsgBox "Sınırı aştınız!", vbCritical
                My_Cell.ClearContents
            End If
        End If
    Next
End Sub

 

[burhancavus61]

Kullandığım çalışma kitabında çok fazla makro var birşeyler etkiliyor sanırım. Son kodu deneyeceğim.

 

[burhancavus61]

Emeğine sağlık hocam oldu teşekkürler

 

[burhancavus61]

Hocam bu verdiğiniz kodları aşağıdaki şekilde uyguladım işimi görüyor. Sadece kodu nasıl sadeleştirebilirim sanırım çok uzattım. Birde E sütununda kullandığım mükerrer kişi kontrol kodu vardı o hata verdi ama çözemedim kodu kaldırdım bende neden hata veriyor acaba?

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Cell As Range
    
    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        If UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ")) = "F" Then
            If Cells(My_Cell.row, "EX").Value > 270 Then
                MsgBox "270 SAAT sınırını aştınız!", vbCritical
            End If
        End If
    Next
    
    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        If UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ")) = "X" Then
            If Cells(My_Cell.row, "EY").Value > 15 Then
                MsgBox "15 PAZAR sınırı aştınız!", vbCritical
            End If
        End If
    Next

    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        If UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ")) = "X" Then
            If Cells(My_Cell.row, "EZ").Value > 14 Then
                MsgBox "14 BAYRAM ve RESMİ TATİL sınırı aştınız!", vbCritical
            End If
        End If
    Next

    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        If UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ")) = "X" Then
            If Cells(My_Cell.row, "FA").Value > 3 Then
                MsgBox "3 AREFE sınırı aştınız!", vbCritical
            End If
        End If
    Next

    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        If UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ")) = "ÜR" Then
            If Cells(My_Cell.row, "FC").Value > 5 Then
                MsgBox "Yıl içerisinde 5 defadan fazla İşveren Tarafından Ödenen rapor hakkını alamaz sınırı aştınız!", vbCritical
            End If
        End If
    Next

    Call tum_bos_satirlari_gizle
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    mm1 = ActiveCell.row * 1
    For MSTF = 2 To mm1 - 1
    If Cells(mm1, "E") <> "" Then
    If Cells(MSTF, "E") = Cells(mm1, "E") Then
    MsgBox "Bu kişi daha önce  " & MSTF & " E hücresine girilmiştir"
    Cells(mm1, "E") = ""
    Exit Sub
    End If
    End If
    Next

End Sub

 

[Korhan Ayhan]

Aşağıdaki satırın sadece "Dim" ile başlayan satırın altında bir kez yer alması yeterli olacaktır.

If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub

Diğerlerini silebilirsiniz.

 

[burhancavus61]

Teşekkür ederim.

 

[ÖmerFaruk]

Sanki biraz daha kısalttım ama bir denemeniz lazım

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Cell As Range
  
    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        Select Case UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ"))
            Case "F"
                If Cells(My_Cell.Row, "EX").Value > 270 Then Mesaj = "270 SAAT sınırını aştınız!": GoTo Son
            Case "X"
                If Cells(My_Cell.Row, "EY").Value > 15 Then Mesaj = "15 PAZAR sınırı aştınız!": GoTo Son
                If Cells(My_Cell.Row, "EZ").Value > 14 Then Mesaj "14 BAYRAM ve RESMİ TATİL sınırı aştınız!": GoTo Son
                If Cells(My_Cell.Row, "FA").Value > 3 Then Mesaj "3 AREFE sınırı aştınız!": GoTo Son
            Case "ÜR"
                If Cells(My_Cell.Row, "FC").Value > 5 Then Mesaj = "Yıl içerisinde 5 defadan fazla İşveren Tarafından Ödenen rapor hakkını alamaz sınırı aştınız!": GoTo Son
        End Select
    Next My_Cell
   Mesaj="İşlem Tamam"
Son:
    MsgBox Mesaj, vbCritical
    Call tum_bos_satirlari_gizle
End Sub

 

[burhancavus61]

Ömer bey yeni deneme fırsatım oldu ilk mesaj kısmında hata verdi

 

[ÖmerFaruk]

Merhaba
Kodların başında Option Explicit kullanıldığı için Mesaj değişkenini tanımlamak şart.
Dosyanız olmadığı için denemeden göndermiştim. Halen de öyle yapıyorum.
Satırları Copy-Paste yaparken bir kaç eksik ve hata vardı. Düzelttim.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim My_Cell As Range
    Dim Mesaj As String
    If Intersect(Target, Range("I6:AM" & Rows.Count)) Is Nothing Then Exit Sub
    For Each My_Cell In Intersect(Target, Range("I6:AM" & Rows.Count))
        Select Case UCase(Replace(Replace(My_Cell.Value, "ı", "I"), "i", "İ"))
            Case "F"
                If Cells(My_Cell.Row, "EX").Value > 270 Then Mesaj = "270 SAAT sınırını aştınız!": GoTo Son
            Case "X"
                If Cells(My_Cell.Row, "EY").Value > 15 Then Mesaj = "15 PAZAR sınırı aştınız!": GoTo Son
                If Cells(My_Cell.Row, "EZ").Value > 14 Then Mesaj = "14 BAYRAM ve RESMİ TATİL sınırı aştınız!": GoTo Son
                If Cells(My_Cell.Row, "FA").Value > 3 Then Mesaj = "3 AREFE sınırı aştınız!": GoTo Son
            Case "ÜR"
                If Cells(My_Cell.Row, "FC").Value > 5 Then Mesaj = "Yıl içerisinde 5 defadan fazla İşveren Tarafından Ödenen rapor hakkını alamaz sınırı aştınız!": GoTo Son
        End Select
    Next My_Cell
    GoTo Devam
Son:
    MsgBox Mesaj, vbCritical
Devam:
    Call tum_bos_satirlari_gizle
End Sub

 

[burhancavus61]

Hocam şimdi sorun çözüldü fakat başka bişey farkettim mesela X attığım zaman diyelim pazar bayram ve arefede aşım varsa üçü içinde mesaj veriyordu şimdi sadece pazar için mesaj veriyor.

 

[ÖmerFaruk]

İlk bulduğu hatanın mesajını veriyor. ve kodlar sonlanıyor. İlk kodlarınızda hata olsa da kodun geri kalanı çalışmaya devam ediyordu.

 

[burhancavus61]

Anladım hocam sağol emeğinize sağlık

 

[burhancavus61]

Hocam bu mesaj konusunu aşağıdaki koddada yaşıyorum
bunuda düzeltmeniz mümkünmü acaba aynı sayfada mükerre kontrolü yapıyordum.

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    mm1 = ActiveCell.row * 1
    For MSTF = 2 To mm1 - 1
    If Cells(mm1, "E") <> "" Then
    If Cells(MSTF, "E") = Cells(mm1, "E") Then
    MsgBox "Bu kişi daha önce  " & MSTF & " E hücresine girilmiştir"
    Cells(mm1, "E") = ""
    Exit Sub
    End If
    End If
    Next
End Sub

 

[ÖmerFaruk]

Burada bir problem göremedim ben.
Hatayı bulduğunda mesajı vermiş
Hücre içeriğini silmiş
ve exit Sub ile de kodu sonlandırmış

 

[burhancavus61]

"Option Explicit" bu kodu eklemeden önce normal çalışıyordu. Bu kodun altında sizin düzenlediğiniz kod sonrada mükerrer kontrol kodum son attığım kod var. Siz kodu revze ederken "Dim Mesaj As String" bu kodu eklemiştiniz mesaj hatasını çözmek için sanırım. Aynısını bu koda da uygulasak çözülür diye düşündüm.

 

[ÖmerFaruk]

mm1 ve MSTF isimli değişkenlerinizi kodların başında tanımlamalısınız.
Option Expicit satırını kullanıyorsanız bunu yapmak zorundasınız.

Bu iki değişken eğer 32767 sayısını aşmayacaklarsa Integer
Dim mm1 As Integer gibi

aşma durumları varsa
Dim mm1 As Long gibi değişken tanımı yapmanız gerekir.