امل المساعدة بالتعديل على الكود اريد حفظ نطاق معين فقط بصيغة pdf

[ابوعلي الحبيب]

           Range("A2:z999" & Cells(Rows.Count, 1).End(xlUp).Row).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    ThisWorkbook.Path & "\" & " " & Range("AA1").Value _
    & " " & Format(Now, "yyyy-mm-dd,hh.mm"), Quality _
    :=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
If a = vbNo Then End

 

السلام عليكم 

 

ياكرام  امل المساعدة بالتعديل على الكود اريد حفظ نطاق معين فقط بصيغة pdf

يوجد كتابة اسفل z1000  لا اريدها ان تظهر 

فقط يحفظ الموجود بينن نطاق z2 الى z 999

ولكم جزيل الشكر

 

 

 

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

السلام عليكم 

كان من الافضل ارفاق الملف

 ولكن على كل حال اليك ملف يقوم بالحفظ في D

DFP1.xlsb

[ابوعلي الحبيب]

اشكرك استاذ عبدالله

 اشكرك على الرد ولكن 

اريده يحفظ الصفوف الموجودة فقط 

الان يحفظ ;كل شي الى z999 حتى لوكانت فارغة 

عند الفرز

احتمال يكون لدي معلومات في النطاق الى 30 صف فقط

وارغب بحفظها 

وبعد مدة تزيد

او يتم الفرز 

واحتاج حفظ المفروز

 

وللمعلومية يوجد بيانات اسفل الصف  999

لذالك اعتقد الحل هو في استخدام

z2:z999.End(xlUp).Row)

ولم استطع اضافتها بالكود بالشكل الصحيح

 

ولك جزيل الشكر

تم تعديل يناير 8 بواسطه ابوعلي الحبيب

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

السلام عليكم 

الحمد لله تم اصلاح العطل بالمنتدى

 

بواسطة  فلترة البيانات بالعمود الاول A يمكن تعديل حسب العمود الذي به بيانات في الجزء 

Field:=1

الكود 

 

Sub SaveRangeAsPDF()
    Dim ws As Worksheet
    Dim savePath As String
    Set ws = ThisWorkbook.Sheets("ورقة1")
    With ws
        .Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>"
        savePath = "D:\" & .Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf"
        .Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False
        .AutoFilterMode = False
    End With
    MsgBox "تم حفظ  الملف بنجاح!", vbInformation, "حفظ PDF"
End Sub

الملف 

DFP2.xlsb

تم تعديل يناير 14 بواسطه عبدالله بشير عبدالله

[محمد هشام.]

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

Sub SaveAsPDF()
    Const Max As Long = 1000
    Dim WS As Worksheet, Irow As Long, OnRng As Range
    Dim xPath As String, Dossier As String, Fichier As String
    
    Set WS = Sheets("Sheet1")
    Irow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row
    If Irow > Max Then Irow = Max: Set OnRng = WS.Range("A2:Z" & Irow)
    
  If Application.WorksheetFunction.CountA(OnRng) = 0 Then Exit Sub
   
   WS.ResetAllPageBreaks
    With WS.PageSetup
        .PrintArea = OnRng.Address: .Orientation = xlPortrait: .PaperSize = xlPaperA4
        .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False
    End With

    Dossier = ThisWorkbook.Path & "\ملفات PDF"
    If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier

    Fichier = Replace(WS.Range("AA1").Value, "/", "_")
    xPath = Dossier & "\" & Fichier & " " & Format(Now, "yyyy-mm-dd hh.mm") & ".pdf"

    WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xPath, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    WS.PageSetup.PrintArea = ""
    MsgBox "تم حفظ الملف بنجاح ", vbInformation
 End Sub

 

Test-PDF.xlsb

[ابوعلي الحبيب]

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