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

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

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

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

أخي الكريم أبو عبد الملك إليك الكود بالكامل ..تم إضافة ثلاثة أسطر لتؤدي الغرض في نهاية الكود قبل جملة End With 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 Call CalculateLinesOfRevision SH.PrintPreview End If Next I 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, N As Long, Counter 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") End With End Sub

المشكلة غريبة نوعاً ما معي تظهر المشكلة أحياناً وتختفي أحياناً يبدو أن المشكلة ليست مشكلة عامة عند الجميع لأني لاحظت أن هناك بعض الأعضاء لا يشتكون من ذلك الأمر ننتظر رأي أ / محمد طاهر بالأمر

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

أخي الغالي جعفر نورت المنتدى بأعمالك الرائعة والمميزة والمتميزة بارك الله فيك وجزاك الله خير الجزاء

ايه يا عم حسام الكلام الجامد ده .. بارك الله فيك وجزاك الله خير الجزاء على ما تقدمه من علمٍ نافع تقبل وافر تقديري واحترامي

أخي الحبيب جعفر بارك الله فيك وجزاك الله خير الجزاء تقبل وافر تقديري واحترامي

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

الأخ الكريم سيد رجب ارفق ملف ليساعدك الأخوة الأعضاء تقبل تحياتي

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

ظهرت معي نفس المشكلة مرة أخرى لدي ويندوز 10 وجربت أكثر من 5 متصفحات (فايرفوكس - جوجل كروم - أوبرا - إنترنت إكسبلورر - سفاري - سبارك ...) وكلها نفس المشكلة هل لنسخة ويندوز 10 علاقة بالمشكلة ؟؟ مع العلم أن هناك منتديات كثيرة لا تظهر فيها مشكلة تصفح الصفحات الأخرى تقبل تحياتي

أخي الكريم أبو عبد الملك مشكور على كلماتك الرقيقة إليك الكود التالي عله يفي بالغرض 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 Call CalculateLinesOfRevision SH.PrintPreview End If Next I 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, N As Long, Counter As Long Dim rngA As Range, rngB As Range, rngC As Range, rngD As Range Dim X, Y 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 End With End Sub

جرب تعدل السطر التالي Found = Application.Match(.Cells(I, "F"), .Range("A4:A" & LR), 0)

أخي الكريم اشرف جرب الكود التالي عله يفي بالغرض Sub TransferWithCriteria() Dim Source As Worksheet, Target As Worksheet Dim LR As Long, I As Long, X As Long Dim SourceRange As Range, Found Set Source = Sheet1: Set Target = Sheet2 LR = Source.Cells(Rows.Count, 1).End(3).Row X = 8 Application.ScreenUpdating = False Target.Range("D8:T1000").ClearContents With Source For I = 4 To LR Found = Application.Match(.Cells(I, "G"), .Range("B4:B" & LR), 0) If IsNumeric(Found) Then If .Cells(Found + 3, 3) >= 50 And .Cells(Found + 3, 4) >= 2 And .Cells(Found + 3, 5) >= 14 Then .Cells(Found + 3, 1).Resize(1, 2).Copy Target.Cells(X, "D").PasteSpecial xlPasteValues .Cells(Found + 3, 3).Resize(1, 3).Copy Target.Cells(X, "R").PasteSpecial xlPasteValues Target.Cells(X, "F").Resize(1, 5).Value = .Cells(I, "H").Resize(1, 5).Value X = X + 1 End If End If Next I End With Source.Activate Application.CutCopyMode = False Application.ScreenUpdating = True MsgBox "Done.", 64 End Sub Transfer Based On Specific Criteria YasserKhalil.rar

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

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

أخي الغالي جعفر بارك الله فيك وجزاك الله خير الجزاء أدامك الله لنا ذخراً ونبراساً للعلم

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

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

أخي محمد يبدو أن التحديث قد أطاح بأشياء تعودنا عليها ولكن ما باليد حيلة

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

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

هذا كود آخر جربه يمكن يتعامل معاك مع الهمزة على نبرة Sub ReplaceChars() Dim ToRemove(), Itm Dim Cel As Range ToRemove() = Array("أ", "إ", "آ") For Each Itm In ToRemove() For Each Cel In Range("F16:F" & Cells(Rows.Count, "F").End(xlUp).Row) Cel.Replace What:=Itm, Replacement:="ا", MatchCase:=True Next Cel Next Itm End Sub يبدو من مشاركتك الأخيرة انك تريد استبدال الحرف الأول فقط عموماً جرب الكود ولن تخسر شيئاً