مطلوب كود لاستكمال ملف الاجر

[سيد الأكـرت]

اساتذتنا الكرام الملف ارجو المساعدة في الملف المرفق وفيه كود لوضع دوائر حمراء على الحصص الزائدة المطلوب تعديل الكود ليتجاهل الخلايا الفارغة ثم جمع الخلايا المحاطة بدوائر حمراء كل يوم ووضعها في الجدول الثاني مع مراعاة إذا كان اليوم غ أو أجازة تكتب مكان العدد ويتم حساب الاجمالي بشكل صحيح وجزاكم الله خيرا

الاجر.xls

[سيد الأكـرت]

هل ممكن كود لاستدعاء حصص المعلم من جدول البيانات حسب تسلسله

[محمد هشام.]

في 27‏/9‏/2024 at 00:11, سيد الأكـرت said:

المطلوب تعديل الكود ليتجاهل الخلايا الفارغة

جرب هدا 

Sub Draw_Circles()
    Const nMax As Integer = 38
    Dim mx, v As Shape, x As Integer, r As Long, c As Long, cnt As Long
    Call Remove_Circles
    x = ActiveWindow.Zoom
    Application.ScreenUpdating = False
    ActiveWindow.Zoom = 100
    mx = Range("s10").Value
    If mx = 0 Or Not IsNumeric(mx) Then MsgBox "Enter Valid Number In Cell s10", vbExclamation: GoTo Skipper
    For c = 8 To 2 Step -1
        For r = 9 To 13 Step 1
            With Cells(r, c)
                If .Value > 0 Then
                    cnt = cnt + 1
                    Set v = .Parent.Shapes.AddShape(msoShapeOval, .Left + 2, .Top + 2, .Width - 4, .Height - 4)
                    v.Fill.Visible = msoFalse
                    v.Line.ForeColor.SchemeColor = 10
                    v.Line.Weight = 2
                    If cnt = mx Then Exit For
                End If
            End With
                  Next r
        If cnt = mx Then Exit For
    Next c
    cnt = 0
Skipper:
    ActiveWindow.Zoom = x
    Application.ScreenUpdating = True
    MsgBox "مبروك...", 64
End Sub

 

[محمد هشام.]

5 ساعات مضت, سيد الأكـرت said:

هل ممكن كود لاستدعاء حصص المعلم من جدول البيانات حسب تسلسله

ادا كنت قد فهمت طلبك بشكل صحيح ربما هدا سيوفي بالغرض سيتم تنفيد الكود عند التغيير في خلية التسلسل (K1) ورقة الأساسي

 

Sub Test()
    Dim dest As Worksheet, WS As Worksheet
    Dim linge As String, arr As Variant
    Dim i As Long, LastRow As Long, OnRng As Range
    Dim Irow As Long, j As Long, Cnt As Long
    Dim dataArr As Variant

    Set WS = Sheets("البيانات")
    Set dest = Sheets("الأساسي")

    linge = dest.[K1].Value

    If linge = "" Then MsgBox "الرجاء إدخال تسلسل المعلم", vbExclamation: Exit Sub
    LastRow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    Set OnRng = WS.Range("A3:A" & LastRow).Find(What:=linge, LookIn:=xlValues, LookAt:=xlWhole)


    If Not OnRng Is Nothing Then
        arr = Array("الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس")
         Irow = 9  ' <<=====   '  تحديد الصف الأول للصق البيانات
         Cnt = 6   ' <<=====   ' ( F عمود)  بداية من يوم الأحـــــــــــــد

        Application.ScreenUpdating = False
        
       ' تكرار لكل يوم (من الأحد إلى الخميس)
        ReDim dataArr(0 To UBound(arr), 0 To 7) ' تخزين 5 أيام و8 أعمدة لكل يوم
        For j = 0 To UBound(arr)
            For i = 0 To 7
                dataArr(j, i) = WS.Cells(OnRng.Row, Cnt + i).Value
            Next i
            Cnt = Cnt + 8
        Next j

        For j = 0 To UBound(arr)
            For i = 0 To 7
                dest.Cells(Irow, i + 2).Value = dataArr(j, i)

                If IsDate(dest.Cells(Irow, i + 2).Value) Then
                    dest.Cells(Irow, i + 2).NumberFormat = "m/d" ''<===== ' قم بتعديل تنسيق التاريخ بما يناسبك

                End If
            Next i
            Irow = Irow + 1
        Next j

        ' جلب المعلومات الإضافية
        dest.[C5].Value = WS.Cells(OnRng.Row, 2).Value ' اسم المعلم
        dest.[K5].Value = WS.Cells(OnRng.Row, 3).Value ' المادة
        dest.[P5].Value = WS.Cells(OnRng.Row, 4).Value ' الوظيفة
        dest.[S9].Value = WS.Cells(OnRng.Row, 5).Value ' النصاب

        ' إجراء الحسابات
        dest.[S8].Value = Application.WorksheetFunction.CountA(dest.Range("B9:I13"))
        dest.[S10].Value = dest.[S8].Value - dest.[S9].Value
      
      ' إظافة الدوائر بعد تنفيد الكود
      ' Call Draw_Circles
    
    Else
        MsgBox "لم يتم العثور على تسلسل المعلم" & linge, vbExclamation
    End If
    Application.ScreenUpdating = True
End Sub

 

 

في 27‏/9‏/2024 at 00:11, سيد الأكـرت said:

جمع الخلايا المحاطة بدوائر حمراء كل يوم ووضعها في الجدول الثاني مع مراعاة إذا كان اليوم غ أو أجازة تكتب مكان العدد ويتم حساب الاجمالي بشكل صحيح

 

 

صراحة لم أستوعب الفكرة حاول تزويدنا بعينة للنتائج المتوقعة بعد تجربة الاكواد السابقة 

 

 

 

 

الاجر V2.xls

تم تعديل منذ 51 دقائق بواسطه محمد هشام.

[سيد الأكـرت]

الله ينور على حضرتك يا باشمهندس محمد هشام تسلم ايديك الكودين ممتازين واوفوا بالغرض وزيادة ربنا يبارك في حضرتك ولو تكمل جميلك ويبقى فيه كود لعد الخلايا المحاطة بدائرة اكون شاكرا لحضرتك وفهم حضرتك للمطلوب صحيح عند تغيير الخلية k1 يتم استدعاء بيانات وجدول المدرس وقد تم بشكل صحيح لأنى قد قمت باستدعاءها بدالة vlookup لكن عند وجود خلية فارغة من الحصص الدالة تضع 0 وهنا كان الكود القديم يحيطها بدائرة لأنها ليست فارغة من وجهة نظره أما كود حضرتك ممتاز فهو يتجاهل الخلايا الفارغة وكود الاستدعاء منع وجود 0 مكان الخلية الفارغة جزاك الله خيرا واتمنى تحقيق الجزء الاخير ليكتمل الملف والمقصود به اذا كان يوجد يوم الاحد 3 حصص محاطة بدائرة حمراء يتم تسجيلها في الجدول الاسفل امام كل يوم الأحد 3 حصص ولو اليوم مفهش يكتب 0 ونستطيع بهذا حساب عدد الحصص الزائدى اسبوعيا عن طريق جمعها وإذا كان اليوم المدرس غائب ممكن ان نكتبها يدويا غ او اجازة ولو امكن معادلة الجمع تكون بتجمع الارقام لان وجود نص زي غ او اجازة هبخلي معادلة sum  تعطى خطأ اتمنى ان اكون اوضحت المطلوب

تم تعديل منذ 2 ساعات بواسطه سيد الأكـرت

[سيد الأكـرت]

هناك ملاحظة بسيطة يا باشمهندس محمد وهي أن اسم الفصل نص يعنى 6/4 مثلا ده تنسيق نص وانا لاحظت ظهوره في جدول الاساسي على انه تاريخ هل يمكن تعديل الجزئية دي في الكود وشكرا لتعب حضرتك 

[محمد هشام.]

لا يمكنني فهم طلبك بدون إرفاق عينة من النتائج المتوقعة كما سبق الدكر  

أما بخصوص تنسيق الخلايا يمكنك تغيير التنسيق على حسب احتياجاتك  بتعديل السطر التالي 

If IsDate(dest.Cells(Irow, i + 2).Value) Then
dest.Cells(Irow, i + 2).NumberFormat = "m/d" ''<===== ' قم بتعديل تنسيق التاريخ بما يناسبك
End If

الى 

If Len(dest.Cells(Irow, i + 2).Value) > 0 Then
dest.Cells(Irow, i + 2).NumberFormat = "@" ' تنسيق نص
End If

قد تم تعديل الكود في الملف المرفق في المشاركة السابقة