نأمل المساعدة في ملف اجازات موظفين

[فهد بن احمد]

السلام عليكم 

الاخوة الزملاء 

ارجو مساعدتي ولكم خالص الشكر

مرفق مثال للملف 

يكون كود او معادلة او تنسيق شرطي 

بحيث اذا تكررت المهنة مثلا 5 او 7 مرات إجازة يكون فيه تنبيه اني تجاوزت الحد لهذا الشهر 

وعامود تاريخ الاستلام يكون عند ادخال كود الموظف ينزل تاريخ اليوم نفسة ولا يتغير في اليوم الثاني 

 

اجاز.xlsx

[عبدالله بشير عبدالله]

وعليكم السلام ورحمة الله وبركانه 

الكود

Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    
    If Not Intersect(Target, Me.Range("B:B")) Is Nothing Then
        Dim c As Range
        For Each c In Target
            If c.Value <> "" And IsEmpty(c.Offset(0, 1).Value) Then
                c.Offset(0, 1).Value = Date
            End If
        Next c
    End If
    
    If Not Intersect(Target, Me.Range("D:D")) Is Nothing Then
        Dim dCell As Range
        For Each dCell In Target
            If dCell.Offset(0, 2).Value = "إجازة" Then
                If Application.WorksheetFunction.CountIfs(Me.Range("D:D"), dCell.Value, Me.Range("F:F"), "إجازة", _
                    Me.Range("E:E"), ">=" & DateSerial(Year(dCell.Offset(0, -1).Value), Month(dCell.Offset(0, -1).Value), 1), _
                    Me.Range("E:E"), "<=" & WorksheetFunction.EoMonth(dCell.Offset(0, -1).Value, 0)) > 5 Then
                    dCell.Interior.Color = RGB(255, 0, 0)
                Else
                    dCell.Interior.ColorIndex = -4142
                End If
            Else
                dCell.Interior.ColorIndex = -4142
            End If
        Next dCell
    End If
    
    Application.EnableEvents = True
End Sub

 

الملف

اجاز.xlsb

تم تعديل الأربعاء at 14:51 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

بعد إذن الأستاد @عبدالله بشير عبدالله  بما ان الكود الخاص به يعتمد على التنسيق  إليك حل آخر باظهار رسالة تنبيه عند تجاوز الحد الاقصى للتكرارات بشرط التاريخ في عمود b

[نفس الشهر ]  واسم المهنة  عمود d والحالة في عمود F 

طريقة الإدخال الكود_ المهنة _الحالة 

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lastRow As Long, Max As Integer, kay As Variant, xdate As Variant
    Max = 5
    Application.EnableEvents = False
    lastRow = Cells(Rows.Count, 4).End(xlUp).Row

    If Not Intersect(Target, Me.Columns("B")) Is Nothing Then
        For Each cell In Target
            If cell.Value <> "" And IsEmpty(cell.Offset(0, 1).Value) Then
                cell.Offset(0, 1).Value = Date
                Else
                cell.Offset(0, 1).Value = ""
            End If
        Next cell
    End If

    If Not Intersect(Target, Me.Range("C5:F" & lastRow)) Is Nothing Then
        For Each cell In Target
            If cell.Column = 6 And cell.Value = "إجازة" Then
                kay = cell.Offset(0, -2).Value
                xdate = cell.Offset(0, -3).Value
                If IsEmpty(kay) Or IsEmpty(xdate) Then
                    MsgBox "يجب إدخال كود الموظف", vbExclamation, "إنتبـــــاه"
                    cell.ClearContents
                    GoTo SupAPP
                End If
        If WorksheetFunction.CountIfs(Range("D5:D" & _
        lastRow), kay, Range("F5:F" & lastRow), "إجازة", Range("C5:C" & lastRow), xdate) > 1 Then
            cell.ClearContents
            MsgBox " تم الوصول للحد الأقصى للإجازات هدا الشهر لسائقين :" & _
              " " & kay, vbExclamation, "إنتبـــــاه"
            GoTo SupAPP
        End If
        If WorksheetFunction.CountIfs(Range("D5:D" & _
        lastRow), kay, Range("F5:F" & lastRow), "إجازة", Range("C5:C" & lastRow), ">=" & WorksheetFunction.EoMonth(xdate, -1) + 1, _
        Range("C5:C" & lastRow), "<=" & WorksheetFunction.EoMonth(xdate, 0)) > Max Then
            cell.ClearContents
            MsgBox "وصلت للحد الأقصى لهذا الشهر في إجازات السائق: " & kay, vbExclamation, "إنتبـــــاه"
        End If
    End If
SupAPP:
        Next cell
    End If

    Application.EnableEvents = True
End Sub

 

 

 

اجاز V1.xlsb

تم تعديل الأربعاء at 19:48 بواسطه محمد هشام.