استبدال المعادلات ب فجوال بيسك

[seaf mohamed]

السلام عليكم 

لدى شيت  اجازات للموظفين يعمل بالمعادلات ارغب فى استبدال المعادلات بكود بالفجوال بيسك بسبب تكرار نوع الاجازة للموظف وبالثالى لا يمكن الاعتماد على المعادلات وشكرا

انتبه من فضلك تم تعديل واعادة رفع الملف بإمتداد XLSM طالما انك تريد الإجابة بالأكواد

attend-v4.xlsm

[سليم حاصبيا]

مبدئياُ هذا الكود لادراج التواريخ لكل شهر ما عدا يوم الجمعة

1- هناك صفوف واعمدة فارغة( مخفية) لفضل الجدول عن بقية البيانات (الصف رقم 8 والاعمدة  I و  AM )

2-نوع الاجازات في عامود واحد (H) لا تنقع لأنه يمكن للموظف ان يأخذ نوعين (أو اكثر) من الاجازات 

 مثلا من تاريخ 1 الى 5 اجازة مرضية و من تاريخ  20 الى 23 اجازة خاصة

الكود (صفحة  Repport)

Option Explicit
Sub Get_Date()
Dim Start_date As Date
Dim End_date As Date
Dim k%, xx, lr%
With Sheets("Repport")
lr = .Cells(Rows.Count, 3).End(3).Row
If lr < 9 Then Exit Sub
 .Range("N9:N" & lr).ClearContents
If Not IsDate(.Range("M3")) Then
 Start_date = #1/1/2021#
 .Range("M3") = Start_date
 Else
 Start_date = .Range("M3")
End If
 End_date = Application.EoMonth(.Range("M3"), 0)
 .Range("U3") = End_date
 k = 10
 .Range("j6").Resize(2, 31).ClearContents
 For xx = Start_date To End_date
  If Format(Day(xx), "dddd") <> "Friday" Then
    .Cells(7, k) = Day(xx)
    .Cells(6, k) = Format(Day(xx), "dddd")
  k = k + 1
  End If
 Next
 .Range("AN9:AN" & lr) = _
 Application.Count(.Range("j7").Resize(, 31))
 
 End With
End Sub

الملف مرفق

seaf mohamed.xlsm

[سليم حاصبيا]

تم التعديل على الملف ليتناسب مع المطلوب

1- تضع نوع الاجازة مباشرة امام اسم الموظف في التاريخ المناسب ثم تضغط على الزر Get Vacation

الخلايا لا تقيل الا القيم

    M   من اجل  Medical leaves   /  او   V   من اجل  Vacation

    A   من اجل  Absence   /  او   U   من اجل  Unpaid

    H   من اجل  Official holiday   /  او   P   من اجل  pay

    E  من اجل emergency leave

الكود لاجل ايام العطلة

Sub Fil_Suumation()
Dim Dic As Object, KY
Dim I%, y%, Col%

Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("Repport")

lr = .Cells(Rows.Count, 3).End(3).Row

If lr < 9 Then Exit Sub
.Range("AO9").Resize(100, 8).ClearContents
 For I = 9 To lr
      For y = 10 To 38
            If .Cells(I, y) <> "" Then
              Dic(UCase(.Cells(I, y).Value)) = ""
            End If
      Next y
   If Dic.Count Then
    For Each KY In Dic
        Select Case KY
         Case "M": Col = 41
         Case "V": Col = 42
         Case "A": Col = 43
         Case "U": Col = 44
         Case "H": Col = 45
         Case "P": Col = 46
         Case "E": Col = 47
        End Select
           .Cells(I, Col) = _
      Application.CountIf(.Cells(I, "j").Resize(, 31), KY)
      Next KY
      Range("AV" & I) = Application.Sum(.Range("AO" & I).Resize(, 7))
     End If
  Dic.RemoveAll
 Next I

 End With
End Sub

 

الملف من جديد

seaf Extra.xlsm

[seaf mohamed]

مش شغال معايا مش عارف اية السبب

[سليم حاصبيا]

عندي يعمل بشكل طبيعي

انظر الضورة

seaf Extra1.xlsm