Bu ay izin kullanmışsa uyarsın. (Mükerrer)

[kelkitli]

Değerli Dostlar Selamlar,
Sub Aktar()
On Error Resume Next
Application.ScreenUpdating = False
Set S1 = Sayfa1
Set S2 = Sayfa3
S1.Select
Range("C9,C10,C11,C12,C13,C14").Copy
S2.Select
Son_Satır = Range("B65536").End(3).Offset(1).Row
Range("A" & Son_Satır) = Son_Satır - 1
Range("B65536").End(3).Offset(1).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=True, Transpose:=True
Application.CutCopyMode = False
S1.Select
Set S1 = Nothing
Set S2 = Nothing
MsgBox "İZİN KAYDI TAMAMLANDI"
End Sub

Bu kodlarla Sayfa1 den Sayfa3 e veri aktarıyorum.
D sütununda isimler G sütununda Tarih var. Yeni bir izin kaydı girerken Eğer bu kişi Bu tarihin ait olduğu ay içinde izin kullanmışsa mükerrer olarak kabul edilsin engellenin ve kullanıcı uyarılsın istiyorum. Ayda bir kez izin hakkı vardır.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Sub Aktar()
    On Error Resume Next
    Application.ScreenUpdating = False
    Set S1 = Sayfa1
    Set S2 = Sayfa3
    S1.Select
        Set BUL = S2.[D:D].Find([C11], LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        ADRES = BUL.Address
        Do
        If Month(S2.Cells(BUL.Row, "G")) = Month(S1.[C14]) Then
        MsgBox S1.[C11] & " isimli personel aynı ay izin kullanmıştır. Lütfen kontrol ediniz !", vbExclamation, "DİKKAT !"
        GoTo Son
        End If
        Set BUL = S2.[D:D].FindNext(BUL)
        Loop While Not BUL Is Nothing And BUL.Address <> ADRES
        End If
        Range("C9,C10,C11,C12,C13,C14").Copy
        S2.Select
        Son_Sat&#305;r = Range("B65536").End(3).Offset(1).Row
        Range("A" & Son_Sat&#305;r) = Son_Sat&#305;r - 1
        Range("B65536").End(3).Offset(1).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=True, Transpose:=True
        Application.CutCopyMode = False
    S1.Select
    MsgBox "&#304;zin kayd&#305; tamamlanm&#305;&#351;t&#305;r."
Son:
    Application.ScreenUpdating = True
    Set S1 = Nothing
    Set S2 = Nothing
End Sub

 

[kelkitli]

Sayın Korhan Ayhan,
Çok teşekkür ederim. Sağolun.

 

[berkeenes]

Galiba Ben salağım programı çalıştıramıyorum