مساعدة في كود لتحويل شيت الاكسل الي pdf

[ATOMats]

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

[عبدالله بشير عبدالله]

السلام عليكم 

اليك مثال على ذلك  حيث يتم انشاء مجلد على سطح المكتب (يمكن تعديله بالكود)

تحويل الى PDF.xlsm

 

[محمد هشام.]

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

جرب هدا

حفظ الملفات في تفس مسار الملف 

Option Explicit
Sub SAVE_PDF()
    Dim ScWS As Variant, Path As String, i As Integer
    ScWS = Array("Sheet1", "Sheet2", "Sheet3")
    Path = ThisWorkbook.Path & "\"

    If Path = "\" Then Exit Sub
    For i = LBound(ScWS) To UBound(ScWS)
        If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub
        Application.ScreenUpdating = False
        On Error Resume Next
        Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        On Error GoTo 0
    Next i
    Application.ScreenUpdating = True
    MsgBox "تم حفظ الملفات بنجاح"
End Sub

لإنشاء مجلد وحفظ الملفات بداخله

Sub SAVE_PDF_Folder()
    Dim ScWS As Variant, Path As String, Dossier As String, i As Integer
    ScWS = Array("Sheet1", "Sheet2", "Sheet3")
    Path = ThisWorkbook.Path & "\"
    Dossier = "ملفات PDF"

    If Path = "\" Then Exit Sub
    If Dir(Path & Dossier, vbDirectory) = "" Then MkDir Path & Dossier
    
    Path = Path & Dossier & "\"
    For i = LBound(ScWS) To UBound(ScWS)
        If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub
        Application.ScreenUpdating = False
        On Error Resume Next
        Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        On Error GoTo 0
    Next i
    Application.ScreenUpdating = True
    MsgBox "تم حفظ الملفات بنجاح"
End Sub
Function ShExists(ByVal SheetName As String) As Boolean
    On Error Resume Next: ShExists = Not Sheets(SheetName) Is Nothing: On Error GoTo 0
End Function

 

 

حفظ الملفات مستقلة بصيغة PDF.xlsb

تم تعديل بالامس في 00:51 بواسطه محمد هشام.