إدخال معلومات حسب الايام

[ahmedhossin]

السلام عليكم و رحمة الله و بركاته المنتدي الوحيد الذي يتم فيه الاجابات هو هذا جعلها الله في ميزان حسنات كل مساهم و مجيب 

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

جزاكم الله خيرا 

 

الاحد و الاثنين و الثلاثاء و الاربعاء و الخميس 

التقرير-اليومي 2022 مبرمج.xlsm

[محمد هشام.]

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

تفضل جرب 

=IF(B22="","",  INDEX(Feuil2!$G$4:G24,   MATCH(B22, Feuil2!$D$4:D24, 0),1))

مع تغير  Feuil2!$G$4:G24   باسم العمود المراد جلب بياناته في باقي الاعمدة

او

=IF(B22<>"",INDEX(Feuil2!E:E,AGGREGATE(15,6,ROW(Feuil2!E$4:E$24)/(Feuil2!$D$4:$D$24=B22),ROWS(C22:C22))),"")

  مع التغيير هنا بما يناسبك (Feuil2!E:E,AGGREGATE(15,6,ROW(Feuil2!E$4:E$24)

=IFERROR(VLOOKUP(Feuil1!$B22,Feuil2!$D$4:$M$24,2,0),"")

 مع استبدال رقم 2 برقم العمود المراد جلب بياناته 

او

=IF(B22="","",XLOOKUP(B22,Feuil2!$D$4:$D$24,Feuil2!$E$4:$E$24))

 

التقرير-اليومي 2022 مبرمج.xlsm

 

تم تعديل أكتوبر 18, 2023 بواسطه محمد هشام.

[ahmedhossin]

ا

اريد حسب الأيام يعني عندما اضع مثلا يوم الاحد تظهر لي الأقسام التي يعمل بها هذا الأستاذ  و هكذا مع باقي الايام 

تم تعديل أكتوبر 18, 2023 بواسطه ahmedhossin

[محمد هشام.]

لكن أخي الملف غير مطابق للصورة المرفقة اين مكان وجود الجدول الذي يتضمن أسماء الأيام 

[ahmedhossin]

هاهو أخي الكريم حزاك الله خيرا 

التقرير-اليومي 2022 مبرمج.xlsm

[ahmedhossin]

الاخ محمد هشام هل من جديد بارك الله فيك 

[محمد هشام.]

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

تفضل اخي 

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

ودالك بتحويل المعادلات الى اكواد 

ووضع لكل يوم كود معين يتم تنفيده بشرط قيمة الخلية  S3  

 

ملاحظة

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

2) تم الاستغناء على معادلة الترقيم التلقائي للبيانات في عمود A  واستبدالها بالاكواد

3) يتم تنفيد الكود  المناسب عند التغيير في عمود الاسماء تلقائيا 

الكود الخاص بيوم الاحد للتوضيح 

 

Sub Sunday()
Dim F1$, F2$, F3$, F4$, F5$, F6$, F7$, F8$, A$, B$, J%
Dim MyRng As Range, MyDst As Range, Title As Range, R As Range, D As Range

Dim MyDest As Worksheet: Set MyDest = Feuil1
Dim MyData As Worksheet: Set MyData = Feuil2

A = MyDest.Name
  B = MyData.Name
    Set C = MyData.Range("$D$4:$M$24")
       Set D = MyDest.Range("A22:A31")
        Set Title = MyDest.Range("B22:B31")
         Set MyRng = MyDest.Range("F22:U31")
Application.ScreenUpdating = False

    MyDest.Unprotect "0000"
     D.ClearContents

With MyDest
   
    F1 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",2,0),"""")"
    F2 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",4,0),"""")"
    F3 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",5,0),"""")"
    F4 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",6,0),"""")"
    F5 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",7,0),"""")"
    F6 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",8,0),"""")"
    F7 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",9,0),"""")"
    F8 = "=IFERROR(VLOOKUP('" & A & "'!$B22,'" & B & "'!" & C.Address & ",10,0),"""")"

[F22] = F1: [H22] = F2: [J22] = F3: [L22] = F4: [N22] = F5: [P22] = F6: [R22] = F7: [T22] = F8
     
.Range("F22:U22").AutoFill Destination:=.Range("F22:U31"), Type:=xlFillDefault
          MyRng.Value = MyRng.Value
          
For Each R In Title
        If R.Value <> Empty Then
         J = J + 1
         R.Offset(0, -1).Value = Format(J, "0")
         End If
       Next
    MyRng.Replace 0, "", xlWhole
 End With
 MyDest.Protect "0000"

End Sub

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

Sub Results()

Select Case Range("S3")
        
        Case "الأحد": Sunday

            Case "الاثنين": Monday

               Case "الثلاثاء": Tuesday
                
                Case "الأربعاء": Wednesday

                  Case "الخميس": Thursday

    End Select

End Sub

 

مع وضع الكود التالي في Worksheet.Change  الورقة 1

Private Sub Worksheet_Change(ByVal Target As Range)
On Error Resume Next
If Not Intersect(Target, Range("B22:B31")) Is Nothing Then
        Application.EnableEvents = False
           Call Results
        Application.EnableEvents = True
   Exit Sub
End If
If Not Intersect(Target, Range("S3")) Is Nothing Then
    Application.EnableEvents = False
        Call Results
    Application.EnableEvents = True
      End If
  On Error GoTo 0
  
End Sub

 

التقرير اليومي مبرمج 2023.xlsm

[ahmedhossin]

اخ هشام جزاك الله خيرا و حفظك و رعاك 

لقد تمت العملية بنجاح باهر و ممتاز لك مني الشكر و الاحترام و التقدير 

دمت لنا اخي و دام عطاءك