مطلوب كود لحفظ الملف بصيغة pdf

[سيد الأكـرت]

السلام عليكم ورحمة الله وبركاته ارجة المساعدة في كتابة كودين لحفظ الملفات بصيغة بي دي اف بحيث يكون الكود الاول للملفات الخاصة بالأول والثاني والثالث وفيه يتم حفظ الملف بنفس الاسم في نفس مكان وجود الشيت اما الكود الخاص بالرابع والخامس والسادس فايضا يحفظ الكود بنفس اسم الملف مع اتاحة خاصية الاختيار لمكان حفظ الملف بحيث احفظه في المكان الذي ارغب فيه ولكم جزيل الشكر 

احصاء.xlsx

[محمد هشام.]

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

هل الملفات يتم حفظها في ورقة pdf واحدة او كل ورقة مستقلة بداتها 

[سيد الأكـرت]

شكرا لتواصلك اخي الكريم كل ورقة لوحدها اقصد مستقلة بذاتها

تم تعديل يوليو 2, 2023 بواسطه سيد الأكـرت

[محمد هشام.]

 

5 ساعات مضت, سيد الأكـرت said:

الكود الاول للملفات الخاصة بالأول والثاني والثالث وفيه يتم حفظ الملف بنفس الاسم في نفس مكان وجود الشيت

تفضل اخي 

Sub Save_PDF()
'Save an array of sheets '1/2/3
Dim ws As Variant
Dim i As Integer, sh As String
Path = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Dim weekSheet As Worksheet
For Each ws In Sheets(Array("الأول", "الثاني", "الثالث"))
With ws
.Activate
   Set weekSheet = ActiveSheet
  weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & weekSheet.Name & ".pdf", _
  Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
End With
Next
For i = 1 To 3
sh = sh & Chr(10) & Chr(10) & ThisWorkbook.Sheets(i).Name
Next
   
MsgBox "تم حفظ الملفات بنجاح" & sh, vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات"
Application.ScreenUpdating = True
End Sub

 

5 ساعات مضت, سيد الأكـرت said:

الكود الخاص بالرابع والخامس والسادس فايضا يحفظ الكود بنفس اسم الملف مع اتاحة خاصية الاختيار لمكان حفظ الملف بحيث احفظه في المكان الذي ارغب

تفضل استاد 

Sub Save_PDF2()
'Save an array of sheets '4/5/6
Dim ws As Variant
Dim Chemin As String
Dim weekSheet As Worksheet

With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
        .Title = "اختيار مسار حفظ الملفات"
        If .Show = -1 Then
        Chemin = .SelectedItems(1) & "\"
For Each ws In Sheets(Array("السادس", "الخامس", "الرابع"))
      With ws
  .Activate
Application.ScreenUpdating = False
Set weekSheet = ActiveSheet
    weekSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & weekSheet.Name & ".pdf", _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
         
     End With
Next
MsgBox (": تم حفظ الملفات بنجاح في " & vbLf & vbLf & vbLf & .SelectedItems(1)), vbOKOnly + vbInformation + vbDefaultButton1 + vbApplicationModal, "معلومات"

                Else
            Exit Sub
        End If
    End With

Application.ScreenUpdating = True

End Sub

بالتوفيق ....

 

احصاء V2.xlsb

[سيد الأكـرت]

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

[محمد هشام.]

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

For i = 1 To Sheets.Count - 3

وهنا حددنا من الشيت الرابع الى اخر شيت على الملف المرفق 

For i = 4 To Sheets.Count

يتبقى لك تعديلهم بما يناسيك 

Sub SAVE_PDF1()
'Save an array of sheets '1/2/3
Dim Path       As String
Path = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
For i = 1 To Sheets.Count - 3
Sheets(i).Select
 
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & ActiveSheet.Name & ".pdf", _
  Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  Next
  MsgBox "تم حفظ الملفات بنجاح"
End Sub

الكود الثاني 

Sub SAVE_PDF2()
'Save an array of sheets '4/5/6
Dim Chemin As String
Application.ScreenUpdating = False
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
        .Title = "اختيار مسار حفظ الملفات"
        If .Show = -1 Then
        Chemin = .SelectedItems(1) & "\"
        Else
        Exit Sub
     End If
For i = 4 To Sheets.Count
Sheets(i).Select
  ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & ActiveSheet.Name & ".pdf", _
  Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
  Next
 End With
MsgBox "تم حفظ الملفات بنجاح"
End Sub

 

احصاء V3.xlsb

تم تعديل يوليو 2, 2023 بواسطه محمد هشام.

[سيد الأكـرت]

جزاك الله خيرا وشكرا جزيلا لحضرتك واسف لتعبك