تعديل كود

[محمد119900]

السلام عليكم استاذة 

(تعديل في كود (شيت نتيجة

 ارجو ان يطبع نتجتين في ورقة A4 

وحفظ الملف بالكامل بصيغه pdf

لجميع الطلاب

كنترول-صف-سادس-أ-ب سجل وسطي.xlsmFetching info...

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

الورقة محمية يجب الغاء التفعيل أولا قبل تنفيد الكود 

[محمد119900]

الرمز هو 

119900

[محمد119900]

  في 1‏/4‏/2025 at 14:16, محمد هشام. said:

وعليكم السلام ورحمة الله تعالى وبركاته 

الورقة محمية يجب الغاء التفعيل أولا قبل تنفيد الكود 

Expand  

الرمز هو 119900

[محمد هشام.]

تفضل جرب هدا 

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

Option Explicit
Const tmp As Long = 45   ' <======= ' إرتفاع صف إسم المدرسة
Private Const CrWS As String = "النتيجة أ"
Private Const sFolder As String = "نتائج التلاميد" ' <=======' إسم مجلد حفظ النتائج
Private Const NamePDF As String = "النتائج"       ' <======='   PDF    إسم الملف المستخرج
Private Const Password As String = "119900"       ' <======= '  باسوورد الأوراق الخاص بك
Sub Copy_SavePDF()
    On Error GoTo SupError
    Dim WS As Worksheet, f As Worksheet, Data As Worksheet, OnRng As Range, rng As Range, myRng As Range
    Dim sPath As String, tempFile As String, arr As Variant, r As Range, Cpt As Long
    Dim lastRow As Long, i As Long, j As Long, début As Integer, fin As Integer

    Set f = Sheets(CrWS): Set Data = Sheets("قوائم شهرية أ")
    If f Is Nothing Or Data Is Nothing Then Exit Sub
    
    SetApp False
    f.Unprotect Password: Data.Unprotect Password
    
    f.[A4].Value = 1
    Set myRng = Data.Range("C7", Data.Range("C" & Data.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeFormulas, 2)
    f.[A3].Value = myRng.Cells(myRng.Rows.Count, 1).Offset(0, -2).Value
    début = f.[A4].Value: fin = f.[A3].Value

    If Not IsNumeric(f.[A4].Value) Or Not IsNumeric(f.[A3].Value) Or début < 1 Or fin < 1 Or début > fin Then GoTo EndSub
    If MsgBox("هل ترغب بحفظ النتائج من " & début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيد") = vbNo Then GoTo EndSub
    
    Set OnRng = f.Range("B7:P35")
    On Error Resume Next
    Set WS = Sheets("PDF")
    On Error GoTo SupError
    If WS Is Nothing Then Set WS = Sheets.Add: WS.Name = "PDF": WS.DisplayRightToLeft = True

    tempFile = ThisWorkbook.Path & "\" & sFolder
    If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile

    For i = début To fin Step 2
        f.[A4].Value = i
        lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).Row
        Set rng = WS.Range("B" & IIf(IsEmpty(WS.[B3].Value), lastRow + 1, lastRow + 5))
        
        OnRng.Copy
        With rng
            .PasteSpecial xlPasteValues: .PasteSpecial xlPasteFormats: .PasteSpecial xlPasteColumnWidths
        End With
        WS.HPageBreaks.Add Before:=WS.Cells(rng.Row + OnRng.Rows.Count, 1)
        Application.CutCopyMode = False
   
        Cpt = rng.Row
        Do While Cpt <= rng.Row + OnRng.Rows.Count - 1
            If Not IsEmpty(WS.Cells(Cpt, 2).Value) Then
                WS.Rows(Cpt).rowHeight = tmp
            End If
            Cpt = Cpt + 15
        Loop
    Next i

    lastRow = WS.Range("B:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set r = WS.Range("B1:P" & lastRow)
    arr = r.Value
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            If arr(i, j) = 0 Then arr(i, j) = ""
        Next j
    Next i
    r.Value = arr

    For i = 4 To lastRow
        If Trim(WS.Cells(i, 2).Value) = "اسم التلميذ/" And _
           (WS.Cells(i, 14).Value = "" Or Not IsNumeric(WS.Cells(i, 14).Value)) Then
            WS.Rows(i).Hidden = True
            If i + 1 <= lastRow Then WS.Rows(i + 1).Hidden = True: If i - 1 >= 4 Then WS.Rows(i - 1).Hidden = True
            For j = i + 2 To lastRow
                WS.Rows(j).Hidden = True
            Next j
            Exit For
        End If
    Next i

    sPath = tempFile & "\" & NamePDF & ".pdf"
    With WS.PageSetup
        lastRow = WS.Range("B:P").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Orientation = xlPortrait: .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False
        .TopMargin = Application.InchesToPoints(0.5): .BottomMargin = Application.InchesToPoints(0.5)
        .LeftMargin = Application.InchesToPoints(0.2): .RightMargin = Application.InchesToPoints(0.2)
        .CenterHorizontally = True: .PrintArea = "B1:P" & lastRow
    End With

    WS.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sPath, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    f.[A4].Value = 1: WS.Delete
    MsgBox "تم حفظ جميع نتائج الطلاب بنجاح", vbInformation

EndSub:
      f.Protect Password: Data.Protect Password
    SetApp True
    Exit Sub

SupError:
    Resume EndSub
End Sub
Private Sub SetApp(ByVal enable As Boolean)
    On Error Resume Next
    Application.ScreenUpdating = enable
    Application.EnableEvents = enable
    Application.DisplayAlerts = enable
End Sub

 

 

النتائج.pdfFetching info... كنترول-صف-سادس-أ-ب سجل وسطي v2.xlsmFetching info...