ياسر خليل أبو البراء

أخي الكريم أبو محمد أشرف اضغط من لوحة المفاتيح Alt + F11 لتدخل لمحرر الأكواد ثم من قائمة Tools اختر الأمر References ثم ابحث عن المكتبة الخاصة بالورد Microsoft Word Object Library وعلم عليها علامة صح .. قد تختلف الرقم الموجود طبقاً للإصدار الذي تعمل عليه .. المهم علم عليها علامة صح وجرب الكود مرة أخرى تقبل تحياتي

أخي الكريم إليك التعديل التالي Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة") With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With With wsRecord For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If Not IsEmpty(.Cells(I, "N")) Then If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then GoTo Continue Else: End If Else Continue: SH.Range("C1") = .Cells(I, "C") SH.Range("C4") = .Cells(I, "B") SH.Range("C5") = .Cells(I, "A") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical End If End If SH.Range("C2").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$B$2:$B$6))" SH.Range("C3").Formula = "=IF(" & SH.Range("R4").Address & "="""","""",LOOKUP(INDEX(QNumbers,MATCH(" & SH.Range("R4").Address & ",QNames,0)),الحلقات!$F$2:$F$6,الحلقات!$D$2:$D$6))" SH.Range("C2:C3").Value = SH.Range("C2:C3").Value SH.PrintPreview End If Next I End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub

جرب الكود التالي عله يكون المطلوب طبعاً استخدمت معاينة الطباعة وليس أمر الطباعة للتجربة افحص النتائج بشكل جيد وأعلمنا بالنتائج هل صحيحة أم غير صحيحة Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range Dim wsRecord As Worksheet, wsMonthly As Worksheet, SH As Worksheet Set wsRecord = Sheets("معلومات التسجيل"): Set wsMonthly = Sheets("مجمع النتائج الشهرية"): Set SH = Sheets("كشف متابعة") With Application .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual End With With wsRecord For I = 2 To .Cells(Rows.Count, "A").End(xlUp).Row If Not IsEmpty(.Cells(I, "N")) Then If MsgBox("الطالب " & .Cells(I, "C") & " منقطع هل تود أن تطبع له كشف?", vbYesNo + vbMsgBoxRtlReading) = vbYes Then GoTo Continue Else: End If Else Continue: SH.Range("C1") = .Cells(I, "C") SH.Range("C4") = .Cells(I, "B") SH.Range("C5") = .Cells(I, "A") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(I, "C"), searchorder:=xlByRows, searchdirection:=xlPrevious) If Not rngFound Is Nothing Then lRow = rngFound.Row If wsMonthly.Cells(lRow, "R") >= 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "N"): SH.Range("S4") = wsMonthly.Cells(lRow, "O") ElseIf wsMonthly.Cells(lRow, "R") < 60 Then SH.Range("R4") = wsMonthly.Cells(lRow, "L"): SH.Range("S4") = wsMonthly.Cells(lRow, "M") Else MsgBox "لا يوجد درجة للطالب " & .Cells(I, "C"), vbCritical End If End If SH.PrintPreview End If Next I End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub

أخي الكريم أين الإضافة التي أضفتها للكود يرجى التوضيح ... توضيح إضافتك للكود إذا كنت تقصد هذا السطر Range("I64").Formula = "=+I62+I61-I63" فلقد تم التعامل معه بالكود مسبقاً فما الفائدة من إخراجه على شكل معادلة ؟

إذاً أضف الكود الأخير الذي تم به حل المشكلة ليستفيد به غيرك من المتابعين للموضوع (الدنيا مش أخد وبس ..الدنيا أخد وعطا)

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

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

أخي الكريم جرب الكود التالي في حدث ورقة العمل كليك يمين على اسم ورقة العمل ثم View Code ثم الصق الكود التالي Private Sub Worksheet_Change(ByVal Target As Range) If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Row > 9 Then If Target.Column = 6 Or Target.Column = 8 Then Application.ScreenUpdating = False Dim I As Long With Sheet1 For I = 10 To .Cells(60, "F").End(xlUp).Row .Cells(I, "I") = .Cells(I, "F") * .Cells(I, "H") Next I .Range("I61") = Application.Sum(.Range("I10:I60")) .Range("I64") = Application.Sum(.Range("I61"), .Range("I62")) - Val(.Range("I63")) End With Application.ScreenUpdating = True End If End If End Sub

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

بارك الله فيك أخي الحبيب سليم وتسلم على المجهود الرائع والمتميز

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

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

هل قمت بتطبيق الكود على نفس الملف أم ملف آخر ؟؟ الكود يعمل معي بشكل طبيعي وعادي جداً ..لأني عادةً لا أرفق كود إلا بعد تجربته أكثر من مرة بالنسبة للمعادلات .. كان من المفترض أن تحدد في المشاركة الأولى أن يكون الحل بالمعادلات ..تحديد الطلب مهم .. عموماً سأحاول أن أقدم لك حل آخر بالمعادلات ..

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

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

أعتقد أن الموضوع مكرر بدون داعي يرجى اتباع التعليمات وتغيير اسم الظهور للغة العربية

أخي الكريم يرجى مراجعة التوجيهات كما يرجى تغيير اسم الظهور للغة العربية عملاً بقواعد المنتدى إليك الطلب الأول فقط أما الطلب الثاني فيمكنك ببساطة شديدة طرح موضوع جديد به الطلب الثاني ولن يتوانى الأخوة الأفاضل بالمنتدى عن تقديم المساعدة ضع الكود التالي في حدث ورقة العمل لينفذ لك المطلوب بمجرد اختيار الشهر Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$H$2" Then Dim WS As Worksheet, SH As Worksheet Dim FindMon, I As Long Set WS = Sheet1: Set SH = Sheet2 With Application .ScreenUpdating = False: .Calculation = xlManual: .EnableEvents = False End With With SH .Range("A4:C12").ClearContents FindMon = Application.Match(.Range("H2").Value, WS.Rows(3), 0) If IsNumeric(FindMon) Then WS.AutoFilterMode = False WS.Rows(3).AutoFilter Field:=FindMon, Criteria1:="<>" & "" WS.Range("B4:B26").SpecialCells(xlCellTypeVisible).Copy .Range("B4").PasteSpecial xlPasteValues WS.Range(WS.Cells(4, FindMon), WS.Cells(26, FindMon)).SpecialCells(xlCellTypeVisible).Copy .Range("C4").PasteSpecial xlPasteValues WS.AutoFilterMode = False Else MsgBox "No Mathing Data", 64: Exit Sub End If If Not IsEmpty(.Range("B4")) Then For I = 4 To .Cells(13, "B").End(xlUp).Row .Cells(I, "A") = .Cells(I, "A").Row - 3 Next I End If .Range("H2").Select End With With Application .EnableEvents = True: .Calculation = xlAutomatic: .ScreenUpdating = True End With End If End Sub وإليك الملف المرفق فيه تطبيق الكود تقبل تحياتي استخلاص بيانات من أعمده وصفوف.rar

أخي الكريم أبو نبأ لم تتعلم من الدرس .. قلت لك خليك في نقطة واحدة عشان تلاقي استجابة (إنت حر ..أنا عن نفسي للأسف ضعيف بالتعامل مع الفورم) لكن نصيحتي ليك ولغيرك .. من يطارد عصفورين يفقدهما فما بالك أرى أولاً وثانياً وثالثاً ..راجع التوجيهات بعناية إذا أردت أن تطاع فأمر بما يستطاع وصدقني الموضوع ذو الطلب الواحد تجد له الكثير من الحلول بعكس الموضوع ذو الطلبات المتعددة (نصيحتي للجميع ..!! ) وحتى أكون فظاً مع البعض (الفظاظو مطلوبة أحياناً ) ....بقول : والله أنا بنصح عايز تاخد بالنصيحة أهلاً وسهلاً بيك وعلى عيني وعلى راسي ، مش عايز تاخد بالنصيحة يبقا إنت حر وتستاهل اللي يجرا لك

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

صراحة لم تمر معي مشكلة مثل هذه المشكلة من قبل .. ننتظر آراء الأخوة الأعضاء

جرب الكود Sub Test() Dim I As Long With Sheet1 For I = 10 To .Cells(60, "F").End(xlUp).Row .Cells(I, "I") = .Cells(I, "F") * .Cells(I, "H") Next I .Range("I61") = Application.Sum(.Range("I10:I60")) .Range("I64") = Application.Sum(.Range("I61"), .Range("I62")) - Val(.Range("I63")) End With End Sub

ممكن ترفق ملفاتك لمحاولة المساعدة .. حيث أنه أمر جديد بالنسبة لي .. ارفق الجدول ومعه ملف إكسيل موضحاً شكل النتائج المتوقعة

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

أعتقد أن المشكلة بالأوفيس وليس بالملف ..حدثت معي نفس المشكلة من فترة فقمت بتغيير الأوفيس وتنصيبه من جديد فحلت المشكلة

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