هانى المعلم

اين انتم يا عمالقه

اخوانى اعضاء المنتدى السلام عليكم ورحمة الله وبركاته لفد تعلمت الكثير على ايدى اخوانى فى هذى المنتدى الرائع واريد من احد الاخوه عمالقة الاكسيل شرح الاكواد الموجوده فى الملف المرفق وهو ملف للاخ عمر الحسينى لعمل الشهادات انا لا اريد شرح لكود الدوائر الحمراء او كود التفقيط الموجود بالملف ولكن اريد شرح الاكواد الموجود باروراق العمل والبوك ورقة الشهادة الكود Private Sub Worksheet_Activate() Sh_Data = "SH" EndRow = Sheets("SH").Cells(Rows.Count, 3).End(xlUp).Row ActiveWorkbook.Names.Add Name:="Tb_1", RefersToR1C1:="=" & Sh_Data & "!R7C2:R" & EndRow & "C60" ActiveWorkbook.Names.Add Name:="All_Names", RefersToR1C1:="=" & Sh_Data & "!R7C2:R" & EndRow & "C3" End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$A$19" And [AA3] = "Circle" Then Application.ScreenUpdating = False DelCircle OmarCircle Application.ScreenUpdating = True End If End Sub والكود الموجود Workbook وهو Private Sub Workbook_BeforeClose(Cancel As Boolean) DelCircle With Sheets("الشهادة") .Range("25:10000").Delete Shift:=xlUp .[AA1:AA3] = "" End With End Sub Private Sub workbook_BeforePrint(Cancel As Boolean) If Not Sheets("الشهادة").Range("AA1") Then Cancel = True: MsgBox " لا يـــوجـــد شـئ للعـــرض او الطبـــاعــة ....... ", vbMsgBoxRtlReading + vbMsgBoxRight + vbExclamation, " تنبيـــة ..." End Sub لانى حاولت تطبيقه ولكن كل محاولاتى فشلت لانى لم افهم الاكواد السابقه وماذا تعنى .[AA1:AA3 وشكرا لكم اخوانى نموذج طباعة الشهادات المدرسية الاصدار الاول.rar

هل من مجيب

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

عمل شهادات.rar اريد عمل اربع شهادات فى صفحه واحده ثم عن طريق الكود يتم طباعة باقى الشهادات التوضيح اكثر بالمرفق عمل شهادات.rar

عثرت على هذا الكود للاخ الفاضل عمر الحسينى واردت تطبيقه ولكنى لم انجح لأنى لا افهم محتويات الكود حيث ان الكود يهدف الى طباعة الشهادات لشيت كنترول واريد تطبيقه على شيت كنترول عندى ولكنى لا استطيع هذا هو الكود الرجاء شرحه ولكم جزيل الشكر Sub ToPrinter() Dim Rng As Range, Num_Rng As Range Dim Per As Single, xx As Double EndRow = Sheets("SH").Cells(Rows.Count, "DD").End(xlUp).Row Set Num_Rng = Sheets("SH").Range("DD1:DD" & EndRow) Counter = Num_Rng.Rows.Count If Counter < 1 Then Exit Sub FRow = 101 Application.ScreenUpdating = False DelCircle DelShadow Select Case [AA3] Case "Shadow" AddShadow Case "Circle" OmarCircle End Select A_Width = Columns("A").ColumnWidth Range("A:A,O:O").ColumnWidth = 14 Application.Cursor = xlDefault For X = 1 To Counter O_Omar_Progress_O.Caption = Space(12) & X & Space(3) & "ãÜä ÅÌãÜÇáÜì" & Space(3) & Counter Per = X / Counter O_Omar_Progress_O.Label_Bar.Caption = Format(Per, "00%") MyProgress Per DoEvents Application.CutCopyMode = False Rows("11:24").Copy Rows(FRow).Insert Shift:=xlDown Range("A" & FRow + 8) = Num_Rng(X) FRow = FRow + 14 If X Mod 3 = 0 Then Rows(FRow - 2).Borders(xlEdgeBottom).LineStyle = xlNone For xx = 1 To 10 ^ 6 a = a + 1 Next Beep Next Application.CutCopyMode = False EndRow = Cells(Rows.Count, 1).End(xlUp).Row + 4 Set Rng = Range("B101:N" & EndRow) Rng.Copy Rng.PasteSpecial xlPasteValues, , False, False Application.CutCopyMode = False EndRow = Cells(Rows.Count, 1).End(xlUp).Row + 3 ActiveSheet.PageSetup.PrintArea = Range("A101:O" & EndRow).Address Range("A:A,O:O").ColumnWidth = A_Width Application.ScreenUpdating = True Range("A1:A10000").ClearContents: [A19] = 1 Sheets("SH").Columns("DD:DD").ClearContents [A1].Select Application.ScreenUpdating = True End Sub Sub SetMe() Dim Ok2Print As Boolean Ok2Print = False Application.ScreenUpdating = False With Sheets("SH") .Columns("DD:DD").ClearContents For Rec = 0 To UserForm1.ListBox1.ListCount - 1 If UserForm1.ListBox1.Selected(Rec) = True Then MyRow = MyRow + 1 .Cells(MyRow, "DD") = UserForm1.ListBox1.List(Rec) UserForm1.ListBox1.Selected(Rec) = False Ok2Print = True End If Next End With [AA1] = Ok2Print Application.ScreenUpdating = True End Sub Sub SetPrinter() Application.ScreenUpdating = False With ActiveSheet.PageSetup .LeftMargin = Application.InchesToPoints(0) .RightMargin = Application.InchesToPoints(0) .TopMargin = Application.InchesToPoints(0.196850393700787) .BottomMargin = Application.InchesToPoints(0.196850393700787) .HeaderMargin = Application.InchesToPoints(0.511811023622047) .FooterMargin = Application.InchesToPoints(0.511811023622047) .CenterHorizontally = True .CenterVertically = True .Orientation = xlLandscape .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .PrintErrors = xlPrintErrorsDisplayed End With Application.ScreenUpdating = True End Sub Sub EndPreview() If [AA1] Then [AA2] = 1 Ok2Me End If End Sub Sub EndPrint() If [AA1] Then [AA2] = 2 Ok2Me End If End Sub Sub Ok2Me() Select Case [AA2] Case 1 ActiveWindow.SelectedSheets.PrintPreview Case 2 ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True End Select End Sub Sub ShowMe() [AA1:AA3] = "" UserForm1.Show End Sub Sub MyProgress(Percent As Single) O_Omar_Progress_O.Label_Bar.Width = Int(O_Omar_Progress_O.Label_Bar.Tag * Percent) End Sub Sub AddShadow() For Col = 3 To 14 Cells(19, Col).FormatConditions.Delete Cells(19, Col).FormatConditions.Add Type:=xlCellValue, Operator:=xlLess, Formula1:=Cells(19, Col).Offset(-2, 0).Value Cells(19, Col).FormatConditions(1).Interior.ColorIndex = 15 Next End Sub Sub DelShadow() Range("C19:N19").FormatConditions.Delete End Sub

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