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

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

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

الاجر.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

 

[محمد هشام.]

7 ساعات مضت, سيد الأكـرت 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

تم تعديل سبتمبر 28 بواسطه محمد هشام.

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

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

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

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

هناك ملاحظة بسيطة يا باشمهندس محمد وهي أن اسم الفصل نص يعنى 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

 

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

مثلا عمود E  

=SUMIF(E16:E20, ">=0")

مما يعني أنها ستتجاهل النصوص مثل "غ" أو "إجازة" وتجمع الأرقام فقط   

نفس الفكرة على عمود الجملة يمكنك استخدام الصيغة التالية مع سحبها للاسفل  ستتجاهل النصوص بشكل تلقائي وتجمع فقط القيم الرقمية

=SUM(E16, G16, I16, K16, M16)

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

 

تم تعديل سبتمبر 28 بواسطه محمد هشام.

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

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

[محمد هشام.]

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

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

لا اعلم أستاد @سيد الأكـرت لمادا انت مصر على عدم إرفاق عينة للنتائج المتوقعة يدويا هل هدا صعب 

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

لا يا باشمهندس محمد انا اسف هو انا بس مش فاهم حضرتك تقصد ايه عشان كده انا مبعتش اللي حضرتك تقصده

ومعذرة لعدم فهمي للمطلوب 

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

انا هرفق لحضرتك صورة من المطلوب ربنا يكون ده اللي حضرتك طلبه 

في الجدول العلوي 12 حصة زائدة موزعة كالاتي حسب الكود 4 حصص يوم الاحد وحصتان يوم الاثنين و3 حصص يوم الثلاثاء وحصتان الاربعاء وحصة الخميس والمطلوب كتابة هذه الاعداد في الجدول الثاني كما في الصورة المرفقة وفي حالة الغياب في احد الايام او الاجازة يمكن كتابتها يدويا بالتبديل مع الرقم الموجود 

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

[محمد العراقى]

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

اجر.xls

[محمد هشام.]

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

ربما هدا ماتقصده 

بما أنك فاهم الكود  سأوضح فقط ما تم تعديله 

 

If Not OnRng Is Nothing Then
        arr = Array("السبت", "الأحد", "الاثنين", "الثلاثاء", "الأربعاء", "الخميس")
        Irow = 10
        cnt = 7

        Application.ScreenUpdating = False
        'افراغ البيانات السابقة
        dest.Range("b10:Q21").ClearContents
        ReDim dataArr(0 To UBound(arr), 0 To 7)
        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 = "@"
                End If
                ' اظافة اسم المادة في الصف الموالي
                If dataArr(j, i) <> "" Then
                    dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row, 3).Value
                End If
            Next i
            Irow = Irow + 2
        Next j
                          '========== جلب المعلومات الإضافية ============
         '  الاسم الرباعي للمعلم' الرقـم القومي ' الفـصــول ' المـــادة' عـدد الحصص المنفذة
        Dim CellArr As Variant, ColArr As Variant
        CellArr = Array("E5", "O5", "C6", "H6", "Q6")
        ColArr = Array(2, 4, 5, 3, 6)

        For i = LBound(CellArr) To UBound(CellArr)
            dest.Range(CellArr(i)).Value = WS.Cells(OnRng.Row, ColArr(i)).Value
        Next i
        
    Else
        MsgBox "لم يتم العثور على تسلسل المعلم " & linge, vbExclamation
    End If

بالتوفيق......

اجر.xls

تم تعديل نوفمبر 19 بواسطه محمد هشام.

[محمد العراقى]

حضرتك فعلا انسان محترم جدا جدا جدا وانا مش بس سعيد بتنفيذ المطلوب وكمان سرعة الاستجابة والتعاون كفاك دعوة خالصة من القلب ان يبارك الله فيك ويحفظك الف مليون شكر 

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

ده فعلا حقيقي رجل محترم بيحب يساعد كل الناس ربنا يجازيه خير 

[محمد العراقى]

معذرة استاذ محمد قد اكون قد قصرت في توصيل المعلومة المطلوبة فانا لم اقصد ان يكتب تحت اسم الفصل اسم المادة الموجودة في العمود الثالث انما اقصد ان يكتب اسماء المواد الموجودة تحت كل فصل ابتداء من العمود G في خانة البيانات مهما اختلف اسمها كما بالصورة بمعنى انني ساغير اسماء هذه المواد 

[محمد هشام.]

ولا يهمك أخي @محمد العراقى   سنكون سعداء دائما بحصولك على النتائج المطلوبة 

يكفي تعديل هدا الجزء من الكود 

For j = LBound(DaysArr) To UBound(DaysArr)
        For i = 0 To 7
            ' الحصص
            dest.Cells(Irow, i + 2).Value = WS.Cells(OnRng.Row, cnt + i).Value
            ' المواد
            If WS.Cells(OnRng.Row + 1, cnt + i).Value <> "" Then
                dest.Cells(Irow + 1, i + 2).Value = WS.Cells(OnRng.Row + 1, cnt + i).Value
            End If
        Next i
        cnt = cnt + 8
        Irow = Irow + 2
    Next j

 

اجر-V2.xls

[محمد العراقى]

الآن قد اكتمل العمل والمطلوب استاذنا الفاضل 

الشكر لا يكفي جزاكم الله خيرا على ما تقدمه لمساعدة الاخرين وجعلكم في ظل الرحمن 

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

ملف ممتاز كامتياز صاحبه جزاكم الله خيرا يا باشمهندس محمد