عاجل اريد شرح هذا الكود لطباعة الشهادات

[هانى المعلم]

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

هذا هو الكود الرجاء شرحه ولكم جزيل الشكر

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

تم تعديل يناير 11, 2014 بواسطه هانى المعلم

[منير لبيب]

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

 

طع الملف  وانا اضع لك الكود  المبسط 

 

[دغيدى]

لماذا كل هذا ؟؟؟

[هانى المعلم]

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

 

طع الملف  وانا اضع لك الكود  المبسط 

 

 

شكرا اخى على سرعة الرد واليك المرفق

تم تعديل يناير 13, 2014 بواسطه هانى المعلم