الدوائر الحمراء في الشهادات

[mhrrd]

لو تكرمتم

هذا مو ملف للاستاذ خبور

وبه كود الدوائر الحمراء

اريد تظبيطه عل ملفي هذا

الفرق عندي 3 شهادات في الصفحة

تفضل كود اضافة الشهادات مع الدوائر

مع ضبط اعدادات تحضير الشهادات للطباعة

شهادة في كل ورقة

كود

Sub KH_ADD_S()

Dim MyRng As Range, MyCell As Range

Dim X As Integer, R As Integer, Y As Integer

Set MyRng = ورقة1.Range("A12:DL51")

Set MyCell = Range("نموذج_الشهادة")

KH_Clear

Application.ScreenUpdating = False

X = 25

MyCell.Copy

For R = 1 To MyRng.Rows.Count - 1

Range("B" & X).PasteSpecial xlPasteAll

X = X + 22

Next R

X = 12

With MyRng

For R = 1 To .Rows.Count

Range("F" & X) = .Range("H" & R)

Range("P" & X) = .Range("B" & R)

Range("E" & X + 7) = .Range("DK" & R)

Range("J" & X + 7) = .Range("DL" & R)

Range("D" & X + 5).RowHeight = 33

For C = 4 To 19

.Cells(R, Cells(1, C)).Copy

Cells(X + 5, C).Select

ActiveSheet.Paste

Selection.PasteSpecial xlPasteValues

Next C

X = X + 22

Next R

With ActiveSheet

Y = .UsedRange.Rows.Count

.PageSetup.PrintArea = "$B$3:$T$" & Y

End With

End With

Application.CutCopyMode = False

Application.ScreenUpdating = True

End Sub

هذا كود حذف الدوائر والشهادات

كود

Sub KH_Clear()

Dim shp As Shape, Y As Integer

Application.ScreenUpdating = False

With ActiveSheet

.Range("F12:L12,P12:Q12,D17:S17,E19:H19,J19:S20").ClearContents

Y = .UsedRange.Rows.Count + 25

.Rows("25:" & Y).Delete

.PageSetup.PrintArea = Range("نموذج_الشهادة").Address

End With

For Each shp In ActiveSheet.Shapes

If shp.AutoShapeType = msoShapeOval Then shp.Delete

Next shp

Activewindow.ScrollRow = 1

End Sub

وشكرا

الكنترول للصف الأول ث تجديد1.rar

الملف المطلوب ادراج فيه الكود.rar

[mhrrd]

لاتنسونا

[علي فاهم]

إن شاء الله فرجه قريب