أبو عبد الملك السوفي

ان شاء الله استاذ ياسر سيبقى البرنامج صدقة جارية لك وانا آسف على كثرت طلباتي مشكور استاذ ياسر

السلام عليكم ممتاز استاذ ياسر عمل أكثر من رائع جزاك الله الجنة

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

هل من متطوع لتعديل كود الاستاذ ياسر

للرفع

للرفع

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

السلام عليكم اود ادخال تعديل للطباعة على الكود التالي الموجود في صفحة كشف المتابعة حيث بدل ان يطبع مباشرة يعطيني الخيار هل تريد طباعة كل كشوف الطلبة معا ام تختار طاب معين لتطبع له 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") 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 End With With Application .ScreenUpdating = True: .EnableEvents = True: .Calculation = xlAutomatic End With End Sub Quran School V14 الرسمي.rar

السلام عليكم بورك في أخي عبد العزيز الامر واضح الآن شكرا جزيلا

السلام عليكم جزاك الله الجنة أستاذ جعفر

السلام عليكم اساتذتنا الكرام كيف يمكن نقل فوروم من ملف الى آخر وهل هذا ممكن

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

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

السلام عليكم أحبابنا الكرام كيف حالكم عندي مشكلة تحدث كلما ركبت كود البحث التالي في الملف ارجوا ان توضحوا لي سبب هاته المشكلة لما الملف لا يقبل هذا الكود ولا قبل اصلا Textbox فعندما افتح Textbox في صفحة البحث واركب الكود في حدث الصفحة يعمل الكود بشكل ممتاز لكن لما اغلق البرنامج وافتحه مرة اخرى يرفض الفتح ويضيع كل كوداته الاخرى حتى لو فتح Textbox ولم اضع اي كود تحدث نفس المشكلة Private Sub TextBox1_Change() Dim LastRow As Long LastRow = Range("C65535").End(xlUp).Row If ActiveSheet.TextBox1.Text <> "" Then Selection.AutoFilter Range("$A$8:$J$" & LastRow).AutoFilter Field:=3, Criteria1:= _ "=" & ActiveSheet.TextBox1.Text & "*", Operator:=xlOr Else Range("$A$8:$J$" & LastRow).AutoFilter Field:=3 End If برنامج المكتبة.rar

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

صور الخطأ في المرفقات My Pictures.rar

لم تصلح استاذ يظهر لي خطأ

السلام عليكم أود أن أغير خاصية المعاينة قبل الطباعة بالطباعة في الكود التالي وهو من تصميم الاستاذ ياسر أبو البراء جزاه الله خيرا ونفع بعلمه 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, 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

السلام عليكم بوركت استاذ ياسر منذ مدة وانا انتظر ردك شكرا جزيلا الكود يعمل بشكل جيد هل يمكن ان تعوض المعاينة بالطابعة الآن

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

السلام عليكم للرفع بورك فيكم مضى على الموضوع أكثر من 10 أيام وأنا في حاجة ماسة لهذا البرنامج جزاكم الله كل خير ونفع بكم

للرفع رفع الله ذكركم

للرفع

للرفع

للرفع