اذهب الي المحتوي
أوفيسنا

هانى المعلم

عضو جديد 01
 عرض الملف الشخصي  عرض المشاركات

  • Posts

    7

  • تاريخ الانضمام

  • تاريخ اخر زياره

 نوع المحتوي 

مشاركات المكتوبه بواسطه هانى المعلم

    شرح كود عمل الشهاده للاخ عمر الحسينى

    في منتدى الاكسيل Excel

    قام بنشر

    اخوانى اعضاء المنتدى السلام عليكم ورحمة الله وبركاته 

    لفد تعلمت الكثير على ايدى اخوانى فى هذى المنتدى الرائع 

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

    انا لا اريد شرح لكود الدوائر الحمراء او كود التفقيط الموجود بالملف ولكن اريد شرح الاكواد الموجود باروراق العمل والبوك

    ورقة الشهادة

     

    الكود

    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

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

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه هانى المعلم

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

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

    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

    اضافة كود طباعة كل الشهادات

    في منتدى الاكسيل Excel

    قام بنشر · تم تعديل بواسطه هانى المعلم

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

    الصف الثانى2.rar

    • Like 1
×
×
  • اضف...

Important Information

  I accept