تكملة الاكواد

[بلانك]

الملف المرفق بداخله المطلوب ....وشكرا لاستاتذه هذا المنتدى مقدما

تكملة الاكواد.xls

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

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

[بلانك]

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

لاستدعاء الغائبين.xls

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

كلنا واحد يا أخي الكريم والأهم إننا نستفيد من أساتذتنا

[ابراهيم الحداد]

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

اخولنى الكرام 

الكود التالى لنقل بيانات الغائبين من شيت data الى شيت غياب لجان

غدا سأحاول تكملة الموضوع ان كان فى العمر بقية

Sub AlAbst()
Dim Data As Worksheet, ws As Worksheet
Dim LR  As Long, x As Integer
Dim Arr As Variant, Tmp As Variant
Dim Mad As String, Cls As String
Dim i As Long, j As Long, p As Long
Set Data = Sheets("data")
LR = Data.Range("B" & Rows.Count).End(3).Row
Set ws = Sheets("غياب لجان")
ws.Range("A11:D100") = ""
Mad = ws.Range("D8").Text
x = WorksheetFunction.Match(Mad, Data.Range("A6:M6"), 0) - 1
Arr = Data.Range("B7:M" & LR).Value
ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For i = 1 To UBound(Arr, 1)
If Arr(i, x) = "غ" Then
p = p + 1
For j = 1 To 4
Tmp(p, j) = Arr(i, Choose(j, 4, 2, 1, 3))
Next
End If
Next
If p > 0 Then ws.Range("A11").Resize(p, UBound(Tmp, 2)).Value = Tmp
End Sub

 

[بلانك]

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

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

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

[بلانك]

ممتاز هذا السؤال من جانبكم واضم صوتي لصوتك يااستاذ سيد الأكرت

[محمد هشام.]

18 ساعات مضت, بلانك said:

كود لنقل البينات الى شيت غياب احمالى وشيت استمارة غياب لان هذا هو المطلوب

ممكن توضح المطلوب اكثر ربما نستطيع مساعدتك العمود الاول والرابع من شيت غياب اجمالي  (م) هل يتم نسخ المادة من الخلية ( D8) او رقم اللجنة المجاورة لاسم التلميد

وبالنسبة لشيت استمارة غياب ماهي طريقة استدعاء التلميد الغائب مثلا ادخال الاسم في خلية معينة او رقم الصف او...............

[بلانك]

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

[محمد هشام.]

تفضل اخي ده كود شيت غياب اجمالي لترحيل اسماء التلاميد الغائبين ورقم الجلوس  وان شاء الله سوف احاول رفع الكود الثاني في المساء بادن الله

Public Sub TEST2()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim Rng As Range
  Dim lr As Long, lr2 As Long
 
  Set sh1 = ThisWorkbook.Worksheets("غياب لجان")
  Set sh2 = ThisWorkbook.Worksheets("غياب إجمالي")
  
  Application.ScreenUpdating = False
'في حالة الرغبة بالاحتفاظ بالبيانات القديمة قم بالغاء تفعيل هدا السطر من الكود
  sh2.Range("A12:G100").ClearContents
  
  With sh1
    Set Rng = .Range("b5:d" & .Cells(.Rows.Count, "A").End(xlUp).Row)
  End With
  With Rng
    .AutoFilter Field:=1, Criteria1:="الرابع"
    lr = sh2.Range("B" & Rows.Count).End(3).Row + 1
    .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("B" & lr)
   
    
    .AutoFilter Field:=1, Criteria1:="الخامس"
    lr = sh2.Range("F" & Rows.Count).End(3).Row + 1
    .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("F" & lr)
    
    .Parent.AutoFilterMode = False
  End With
  Application.ScreenUpdating = True
End Sub

 

تم تعديل يناير 10, 2023 بواسطه Mohamed Hicham

[بلانك]

بارك الله فيك استاذي محمد هشام واسفين على تعب حضرتك معنا الكود يعمل بشكل ممتاز ........ ونطمع في الكود الثاني ان شاء الله

[بلانك]

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

إستدعاء الغائبين.xls

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

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

اظن ان المشكلة في الكود في ترقيم الخلية b 5 

[بلانك]

بالفعل عندك حق !!!!!!!!!!!!!!!!!!!!!!!

[محمد هشام.]

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

[محمد هشام.]

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

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

[بلانك]

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

[محمد هشام.]

أولا آسف على التاخير بسبب ضيق الوقت. 

تفضل اخي تم تعديل الكود مع مراعات عدم وجود الغياب في إحدى المواد أو عدم وجود صف بالكامل

Public Sub Filtre_de_classe()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim Lr As Long, i As Long
  Dim Rng As Range
  Dim Arr As Variant
  Set sh1 = ThisWorkbook.Worksheets("غياب لجان")
  Set sh2 = ThisWorkbook.Worksheets("غياب إجمالي")
  XRng = sh1.Range("D8")

Application.ScreenUpdating = False
sh1.Activate
        ' التحقق من وجود بيانات في جدول غياب لجان

    Arr = Array([A11], [B11], [C11], [D11])
    For i = 0 To 3
        If Arr(i) = "" Then
 MsgBox (" لا يوجد تلاميد غائبين في مادة : " & XRng)
            Arr(i).Select
            sh2.Activate
            Exit Sub
        End If
    Next
    
sh2.Range("A12:G1000").ClearContents
With sh1
Set Rng = .Range("B5:D" & .Cells(.Rows.Count, "A").End(xlUp).Row)
  End With
   With Rng
    
    With Rng
    Dim cntCrit As Long
    ' التحقق من وجود غياب في الفصل 4
    cntCrit = WorksheetFunction.CountIfs(Rng.Columns(1), "الرابع")
    If cntCrit <> 0 Then
        .AutoFilter Field:=1, Criteria1:="الرابع"
        Lr = sh2.Range("B" & Rows.Count).End(3).Row + 1
        .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("B" & Lr)
    End If
  End With
  
  
  With Rng
  '5 التحقق من وجود غياب في الفصل
    cntCrit = WorksheetFunction.CountIfs(Rng.Columns(1), "الخامس")
    If cntCrit <> 0 Then
        .AutoFilter Field:=1, Criteria1:="الخامس"
        Lr = sh2.Range("F" & Rows.Count).End(3).Row + 1
        .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1).Copy sh2.Range("F" & Lr)
    End If
  End With
    .Parent.AutoFilterMode = False
End With
sh2.Activate
  Application.ScreenUpdating = True
End Sub

أما بالنسبة لملئ الإستمارة  بشرط  اسم التلميذ في الخلية (C8) يمكنك إستخدام الكود التالي :

 

Sub Récupérer_des_données()
Dim sh As Worksheet
Dim Lr As Long
Dim Rng1 As Range
Set sh1 = ThisWorkbook.Worksheets("استمارة غياب")
Set sh2 = ThisWorkbook.Worksheets("غياب لجان")
Lr = sh2.Cells(sh2.Rows.Count, 3).End(xlUp).Row
Set Rng1 = sh1.Range("H8,H10,H12,C10,C12,C14")
Rng2 = sh1.Range("C8")

Application.ScreenUpdating = False
 With sh2
    Set Trouve = .Range("C:C").Find(what:=Rng2, LookIn:=xlValues, lookat:=xlWhole)
     If Trouve Is Nothing Then
       MsgBox "اسم التلـميذ غير موجود في القائمة", Exclamation, "غياب لجان"
       Rng1.Select
       Selection.ClearContents
       Range("C8").Select
       Exit Sub
     Else
     End If
     
If Len(Range("C8").Value) = 0 Then
MsgBox "المرجوا إدخال إسم التلـميذ", Exclamation, "استمارة غياب"
 Exit Sub
End If

sh2.Activate
For i = 11 To Lr
If sh2.Cells(i, 3).Value = Rng2 Then
sh1.Range("H12").Value = Range("A" & i).Value
sh1.Range("C12").Value = Range("B" & i).Value
sh1.Range("C10").Value = Range("D" & i).Value
sh1.Range("H8").Value = sh2.Range("F8").Value
sh1.Range("C14").Value = sh2.Range("F8").Value
sh1.Range("H10").Value = sh2.Range("D8").Value
          End If
    Next i
   End With
   sh1.Activate
Application.ScreenUpdating = True

End Sub

ملاحظة: قد تم حذف غياب اللغة العربية للتجربة

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

 

استدعاء الغائبين_3.xls

تم تعديل يناير 11, 2023 بواسطه Mohamed Hicham

[بلانك]

شكرا جزيلا لاستاذنا محمد هشام واكثر الله من امثالك تمام كدا فقط للعلم فقد غيرت sh1.Range("H8").Value = sh2.Range("F8").Value الى   sh1.Range("H8").Value = sh2.Range("B8").Value  والخاص بالغياب في استمــارة غيـــاب لانه يعطي الفترة بدل من التاريخ بعد اذن حضرتك والكود يعمل بشكل رائع وجميل

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

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