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

أخي الحبيب ياسر اعذرني لم ألحظ التغيير الذي تم في الملف .. بارك الله فيك على الإضافة الرائعة

أخي الحبيب ياسر دا عشمي فيك بردو إنك متزعلش بالنسبة للمرفق الأخير الكود لا يعمل مع الأرقام ..جرب تغير النطاق إلى C و D

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

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

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

أخي الحبيب محمد نصري الكود يعطي خطأ في هذا السطر Application.Goto A.Offset(0, -1), True أعتقد ان لب الموضوع هو فتح المصنف وعمل سكرول لآخر خلية كانت محددة قبل الإغلاق مباشرة بصرف النظر عن آخر خلية بها بيانات .. تقبل تحياتي

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

أخي الكريم أبو عبد الملك إليك الكود بعد التعديل عله يفي بالغرض (يرجى مراجعة النتائج جيداً ...لأنني لم اختبر الكود بشكل كافي) Sub FollowAll() Dim I As Long, lRow As Long Dim rngFound As Range, Answer 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 If MsgBox("هل تريد طباعة كل كشوف الطلبة أم تريد أن تختار طالب معين؟", vbYesNo + vbMsgBoxRtlReading) = vbYes Then 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") SH.Range("R5") = .Cells(I, "Q") 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 Call CalculateLinesOfRevision SH.PrintPreview End If Next I Else Answer = Application.InputBox("أدخل رقم الطالب بناءً على ورقة معلومات التسجيل", "Input", 1) SH.Range("C1") = .Cells(Answer + 1, "C") SH.Range("C4") = .Cells(Answer + 1, "B") SH.Range("C5") = .Cells(Answer + 1, "A") SH.Range("R5") = .Cells(Answer + 1, "Q") Set rngFound = wsMonthly.Columns("C:C").Find(What:=.Cells(Answer + 1, "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(Answer + 1, "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 Call CalculateLinesOfRevision SH.PrintPreview End If End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub Private Sub CalculateLinesOfRevision() Dim SH As Worksheet, wsMnhg As Worksheet Dim LRCur As Long, I As Long, II As Long, N As Long, Counter As Long, P As Long Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range Dim X, Y, Z Set SH = Sheets("كشف متابعة"): Set wsMnhg = Sheets("المنهج") With wsMnhg LRCur = .Cells(Rows.Count, 1).End(xlUp).Row Set rngA = .Range("A2:A" & LRCur): Set rngB = .Range("B2:B" & LRCur) Set rngC = .Range("C2:C" & LRCur): Set rngD = .Range("D2:D" & LRCur) SH.Range("Q11:Q34").ClearContents X = ValueLookUp(rngB, SH.Cells(4, "R").Value, rngC, rngD, SH.Cells(4, "S").Value, rngA) If X <= 24 Then For I = 2 To X + 1 SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I, "B") & " " & .Cells(I, "D") N = N + 1 Next I Else Y = Application.WorksheetFunction.Ceiling(X / 24, 1) For I = 2 To X + 1 Step Y SH.Cells(N + 11, "Q") = .Cells(I, "B") & " " & .Cells(I, "C") & " - " & .Cells(I + Y - 1, "B") & " " & .Cells(I + Y - 1, "D") N = N + 1 Counter = Counter + Y If Y >= X - I Then Exit For Next I If X - Counter > 0 Then SH.Cells(N + 11, "Q") = .Cells(I + Y, "B") & " " & .Cells(I + Y, "C") & " - " & .Cells(X + 1, "B") & " " & .Cells(X + 1, "D") End If SH.Range("O11:O34").ClearContents Z = X - 24 If Z > 0 Then SH.Range("O11:O34") = .Cells(Z, "B") & " " & .Cells(Z, "D") & " - " & SH.Range("R4") & " " & SH.Range("S4") SH.Range("M11:M34,I11:I34,G11:G34").ClearContents P = 1 For II = 11 To 34 SH.Range("M" & II) = .Cells(X + P, "B") & " " & .Cells(X + P, "C") & " - " & .Cells(X + P, "D") SH.Range("I" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 1, "D") SH.Range("G" & II) = .Cells(X + P + 1, "B") & " " & .Cells(X + P + 1, "C") & " - " & .Cells(X + P + 6, "B") & .Cells(X + P + 6, "D") P = P + 1 Next II SH.Range("M11:M34").Copy SH.Range("K11") End With End Sub

أخي الكريم أهلاً ومرحباً بك بين إخوانك بالمنتدي نتمنى قضاء أمتع الأوقات مع إخوانك وأحبابك يرجى تغيير اسم الظهور للغة العربية لمعرفة مزيد من التفاصيل يرجى الإطلاع على رابط التوجيهات في الموضوعات المثبتة بالمنتدى إليك الملف المرفق عله يفي بالغرض تم إنشاء عدد 2 مربع نصوص TextBox ActiveX Controls تم وضع الكود بهذا الشكل في حدث تغير مربعات النصوص ليؤدي الغرض Private Sub TextBox1_Change() Range("A6:E6").AutoFilter Field:=2, VisibleDropdown:=False Range("A6:E6").AutoFilter Field:=2, Criteria1:="=*" & TextBox1 & "*" End Sub Private Sub TextBox2_Change() Range("A6:E6").AutoFilter Field:=1, VisibleDropdown:=False Range("A6:E6").AutoFilter Field:=1, Criteria1:="=*" & TextBox2 & "*" End Sub Phone Directory.rar

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

ممتاز أخي الحبيب سليم أعتبر كودك هو الأفضل إلى الآن في هذا الموضوع صراحةً لم يخطر ببالي الاعتماد على Selection وهي فكرة رائعة رائعة وأعجبتني كثيراً تسلم وربنا يجازيك كل خير أما صاحب الموضوع فيبدو أنه لم يعد مهتماً بالموضوع .. نلتمس له العذر

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

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

أخي إبراهيم الأبيض أين الملف المرفق؟ ارفق الملف ومعه كلمة السر ما المقصود بكلمة "أعمل روسات"؟

أخي العزيز عزيز 60 (يا ريت الـ 60 تبقا لقب مش رقم) بالنسبة لطلبك رغم إنه يبدو سهل إلا إنه غير مفهوم للتأكيد فقط .. هل تريد إخفاء الصف في حالة وجود النص "منتقل" في العمود AR ..أقصد شرط الإخفاء هو أن يكون الصف فارغ ..أم أنه يحتوي على كلمة منتقل ؟؟ يرجى التوضيح ليساعدك الأخوة الأحباب بالمنتدى

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

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

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

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

الأروع هو تواجدك معنا ونشاطك الجميل والرائع أخي الحبيب وائل إني أحبك في الله

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

أخي الكريم فضل 1 (أرجو أن تغير رقم 1 في اسم الظهور بلقبك ..) بالنسبة لطلبك ..جرب الدالة المعرفة التالية ... Function IsCountGTE(ByVal Rng As Range) Dim Cnt As Long Dim Data As Variant Dim Item As Variant Application.Volatile Data = Rng.Value If Application.WorksheetFunction.CountIf(Rng, "غ") = 0 Then IsCountGTE = "": Exit Function For Each Item In Data If IsEmpty(Item) Then Cnt = 0 ElseIf Item = "غ" Then Cnt = Cnt + 1 End If If Cnt = 5 Then IsCountGTE = "متتالي" Exit Function End If Next Item IsCountGTE = "غير متتالي" End Function وإليك الملف المرفق يوضح كيفية استخدامها Count Contiguous Cells Only.rar

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

أخي الكريم ناصر إليك الملف المرفق فيه طلبك Grab Data Using Arrays.rar

أخي الكريم أحمد مرجان بدايةً يوجد مشكلة بالملف أن العمليات الحسابية يدوي .. قم بالذهاب للتبويب Formulas ثم Caculation Options ثم اختر Automatic طبعاً أنا لم أراجع المعادلة ولكني استنتجت أن هناك خطأ في المدخلات .. قمت بعمل معادلة كالتالي في الخلية N8 ثم سحبها عبر الصف =CLEAN(TRIM(N3)) لكي أقوم بحذف المسافات الزائدة إن وجدت ثم قمت بوضع معادلة أخرى في الخلية N10 ثم سحبها عبر الصف =IF(EXACT(N3,N8),"","Wrong") ثم نظرت في الصف العاشر فوجدت كلمة Wrong في الخلية BO10 فعلمت أن هناك مشكلة في الخلية BO3 .. قم بعمل مسح للخلية من خلال تحديد الخلية ثم الضغط على مفتاح Delete لحذف المحتويات في الخلية . ستجد أن الناتج هو 20 كما توقعت أرجو أن يكون المطلوب