طلب تصحيح كود pdf

[hicham2610]

السلام عليكم

من فضلكم

كيف أطور الكود الموجود في زر pdf في ورقة:bulletin_sem

Sub PDF()
If Not ActiveSheet.Name Like "bulletin*" Then Exit Sub 'sécurité
Dim chemin$, rep As Byte, a$, h&, i&
chemin = ThisWorkbook.Path & "\Sauvegarde\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création du dossier
rep = MsgBox("Grouper en un seul fichier PDF ?'", 3)
If rep = 2 Then Exit Sub
Application.ScreenUpdating = False
With ActiveSheet
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesTall = 1 '1 page en hauteur, détermine le zoom
    If rep = 6 Then 'Oui
        a = .PageSetup.PrintArea
        h = .Range(a).Rows.Count
        .Copy 'nouveau document
        With ActiveSheet
            .PageSetup.PrintArea = ""
            For i = 1 To Val(.[N7] - 1)
                .Range(a).EntireRow.Offset(h * i - h).Copy .[A1].Offset(h * i)
                .[N5].Offset(h * i) = i + 1
                .HPageBreaks.Add Before:=.[A1].Offset(h * i) 'saut de page
            Next
            .PageSetup.PrintArea = .Range(a).Resize(h * i).Address
            .PageSetup.FitToPagesTall = i
            .ExportAsFixedFormat xlTypePDF, chemin & "Groupé.pdf"
            .Parent.Close False 'fermeture du document
        End With
        MsgBox "Fichier PDF groupé publié..."
    Else 'Non
        For i = 1 To Val(.[N7])
            .[N5] = i
            .ExportAsFixedFormat xlTypePDF, chemin & .[N5] & ".pdf"
        Next
        .[N5] = 1
        MsgBox i - 1 & " fichier(s) PDF publié(s)..."
    End If
End With
End Sub

بحيث عند اختيار groupé أي نتائج pdf  في ملف واحد pdf مجتمعة تكون النتيجة سليمة بدل هذه النتيجة التي فقط تقتصر على تغيير الرقم و إعادة نسخ نتيجة التلميذ الأول

أما النتيجة السليمة أن تجمع نتائج المتعلمين ال 24 في pdf واحد وجزاكم الله خيرا

وجزاكم الله خيرا

111.xlsm

[hicham2610]

السلام عليكم

 

 

السلام عليكم

توصلت إلى هذا الكود:

Sub PDF()
If Not ActiveSheet.Name Like "bulletin*" Then Exit Sub 'sécurité
Dim chemin$, rep As Byte, a$, h&, i&
chemin = ThisWorkbook.Path & "\Sauvegarde\"
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création du dossier
rep = MsgBox("Grouper en un seul fichier PDF ?'", 3)
If rep = 2 Then Exit Sub
Application.ScreenUpdating = False
With ActiveSheet
    .PageSetup.Zoom = False
    .PageSetup.FitToPagesTall = 1 '1 page en hauteur, détermine le zoom
    If rep = 6 Then 'Oui
        a = .PageSetup.PrintArea
        h = .Range(a).Rows.Count
        .Copy 'nouveau document
        With ActiveSheet
            .PageSetup.PrintArea = ""
            For i = 1 To Val(.[N7] - 1)
                .Range(a).EntireRow.Offset(h * i - h).Copy .[A1].Offset(h * i)
                .[N5].Offset(h * i) = i + 1
                .HPageBreaks.Add Before:=.[A1].Offset(h * i) 'saut de page
            Next
            .PageSetup.PrintArea = .Range(a).Resize(h * i).Address
            .PageSetup.FitToPagesTall = i
            .ExportAsFixedFormat xlTypePDF, chemin & "Groupé.pdf"
            .Parent.Close False 'fermeture du document
        End With
        MsgBox "Fichier PDF groupé publié..."
    Else 'Non
        For i = 1 To Val(.[N7])
            .[N5] = i
            .ExportAsFixedFormat xlTypePDF, chemin & .[N5] & ".pdf"
        Next
        .[N5] = 1
        MsgBox i - 1 & " fichier(s) PDF publié(s)..."
    End If
End With
End Sub

بالضغط على زر PDF في ورقة BULLETINS_SEMيتم استصدار النتائج على شكل pdf  باختيار إما نتائج  متفرقة فتخرج كل النتائج فردية: لكل متعلم نتيجته او كلها مجموعة في ملف بدإف واحد

هذه النتائج يتم وضعها أوطوماتيكيا في ملف باسم:  sauvegarde  في نفس مكان تواجد البرنامج

إخوتي الكرام

ما العيب  الموجود في الكود ؟ عند الاختيار الثاني: كلها مجموعة في ملف بدإف واحد

لا أجد كل نتيجة في صفحة ،حدث خطأ  : بحيث تجد مثلا 24 نتيجة في 23 صفحة

نتيجة في صفحتين/ نتيجة في صفحة ومباشرة ابتدأت نتيجة أخرى وهذا عيب

ينبغي أن تكون كل نتيجة في صفحة والكل في بدإف واحد

ومعذرة على الازعاج

وجزاكم الله خيرا       

تم تعديل أغسطس 18, 2018 بواسطه hicham2610