المطلوب تحويل ورقة لجان 4 الى pdf

[خالد المصـــــــــــرى]

المطلوب  تحويل ورقة لجان 4 الى   pdf

المصنف1.xlsb

[عبدللرحيم]

تفضل لعله المطلوب إن شاء الله

ok المصنف1.xlsb

[خالد المصـــــــــــرى]

خطا لان متغير حسب s8

[خالد المصـــــــــــرى]

@محمد هشام. ارجو الحل

[محمد هشام.]

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

جرب هدا  

Private Const sFolder As String = "ملفات PDF"
Private Const CrWS As String = "لجان 4"
Sub SavePDF()
    Dim f As Worksheet, début As Integer, fin As Integer, i As Integer
    Dim sPath As String, sName As String, tempFile As String
    Set f = Sheets(CrWS)
    If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub
    début = f.[B1].Value: fin = f.[S2].Value
    If début < 1 Or fin < 1 Or début > fin Then Exit Sub
    If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub
    
    Application.ScreenUpdating = False
    tempFile = ThisWorkbook.Path & "\" & sFolder
    If Dir(tempFile, vbDirectory) = "" Then MkDir tempFile
    
    For i = début To fin Step 2
        f.[B1].Value = i
        sName = f.[F7].Value & IIf(f.[M7].Value <> "", " - " & f.[M7].Value, "")
        sPath = tempFile & "\" & "Page - " & sName & ".pdf"
        
        On Error Resume Next
        f.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        On Error GoTo 0
    Next i
    
    Application.ScreenUpdating = True
    MsgBox "تم حفظ الملفات بنجاح", vbInformation
End Sub

 

 

المصنف v2.xlsb

[خالد المصـــــــــــرى]

@محمد هشام. تمام بس فيه تعديل انه يحفظ كل الاوراق في ملف pdf واحد ثانيا يتحفظ ف ي نفس مكان الملف وثالثا يرجع f7  الى 1 بعد الحفظ

 

[محمد هشام.]

37 دقائق مضت, خالد المصـــــــــــرى said:

انه يحفظ كل الاوراق في ملف pdf واحد ثانيا يتحفظ ف ي نفس مكان الملف وثالثا يرجع f7  الى 1 بعد الحفظ

1) للأسف طريقة إشتغالك على الملف لن تمكنك من حفظ جميع الملفات على ملف واحد PDF  

لاكن هناك حلول بديلة وهي إما دمجها يدويا من خلال برامج خارجية بعد الحفظ أو محاولة إظافة ورقة جديدة يتم نسخ الصفحات المطلوبة إليها تحت بعضها البعض وبالتالي تنسيق وحفظ الورقة في ملف مستقل وهدا يتطلب تعديل  كود و طريقة الحفظ

2) مكان الحفظ الحالي هو مجلد في نفس مسار المصنف  بإسم  ملفات PDF

3) مسألة إرجاع قيمة الخلية F7 بعد الحفظ الى 1 يكفي في أخر الكود وضع 

f.[B1].Value = 1

 

 

 

تم تعديل مارس 17 بواسطه محمد هشام.

[محمد هشام.]

سوف أحاول تنفيد الفكرة السابقة بإظافة ورقة مخفية لدمج الملفات  وإعادة رفع الملف لاكن ربما يجب عليك تقليص عدد الصفوف على ورقة لجان 4  الى 44  لتتماشى مع تنسيق صفحات Pdf  ادا لم يكن لديك مانع في دالك 

 

[محمد هشام.]

تفضل أخي 

 

 

Private Const sFolder As String = "الكشوفات PDF"
Private Const NamePDF As String = "كشف مناداة"
Private Const CrWS As String = "لجان 4"
Private Const Logo As String = "IMG"

Sub Copy_SavePDFfinal()
    Dim WS As Worksheet, début As Integer, fin As Integer, i As Integer, row As Integer
    Dim sPath As String, tempFile As String, img As Shape, r As Shape
    Dim lastRow As Long, Rng As Range, OnRng As Range

    
    Dim f As Worksheet: Set f = Sheets(CrWS)
    
    If Not IsNumeric(f.[B1].Value) Or Not IsNumeric(f.[S2].Value) Then Exit Sub
    début = f.[B1].Value: fin = f.[S2].Value
    Set OnRng = f.Range("B2:O45")

    If début < 1 Or fin < 1 Or début > fin Then Exit Sub
    If MsgBox("هل ترغب بحفظ الصفحات من " & début & " إلى " & fin & "؟", _
                vbYesNo + vbExclamation, "تأكيـــد") = vbNo Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    On Error Resume Next
        Set WS = Sheets("PDF")
        If WS Is Nothing Then
        Sheets.Add.Name = "PDF"
        Set WS = Sheets("PDF")
        WS.DisplayRightToLeft = True
    End If
    On Error GoTo 0

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

    For i = début To fin Step 2
        f.[B1].Value = i
        lastRow = WS.Cells(WS.Rows.Count, "B").End(xlUp).row
        If WS.Cells(2, 3).Value = "" Then
            Set Rng = WS.Range("B" & lastRow + 1)
        Else
            lastRow = WS.Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
            Set Rng = WS.Range("B" & lastRow + 5)
        End If

        OnRng.Copy
        Rng.PasteSpecial Paste:=xlPasteValues
        Rng.PasteSpecial Paste:=xlPasteFormats
        Rng.PasteSpecial Paste:=xlPasteColumnWidths
        WS.Cells.NumberFormat = "0;-0;;@"

        On Error Resume Next
        Set img = f.Shapes(Logo)
        If Not img Is Nothing Then
            img.Copy
            WS.Paste Destination:=WS.Cells(Rng.row - 1, "F")
            Set img = WS.Shapes(Logo)

            img.Top = img.Top
            If img.Left + img.Width > WS.Range("O1").Left Then
                img.Left = WS.Range("O1").Left - img.Width
            End If
            If img.Top + img.Height > WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top Then
                img.Top = WS.Range("A:O").Rows(WS.Range("A:O").Rows.Count).Top - img.Height
            End If
        End If
        On Error GoTo 0

        For row = 1 To OnRng.Rows.Count
            WS.Rows(Rng.row + row - 1).RowHeight = OnRng.Rows(row).RowHeight
        Next row

        WS.HPageBreaks.Add Before:=WS.Cells(Rng.row + OnRng.Rows.Count, 1)

        With WS.PageSetup
            .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
        End With

        Application.CutCopyMode = False
    Next i

    sPath = tempFile & "\" & NamePDF & ".pdf"
    On Error Resume Next
    WS.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    On Error GoTo 0
    
    f.[B1].Value = 1
    WS.Delete
    Application.DisplayAlerts = True

    Application.ScreenUpdating = True
    MsgBox "تم حفظ الملفات بنجاح", vbInformation
End Sub

 

المصنف v3.xlsb

تم تعديل مارس 18 بواسطه محمد هشام.

[خالد المصـــــــــــرى]

@محمد هشام. شكرا ده المطلوب