المساعده فى تعديل كود .. pdf

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

الاخوة الكرام 

ارجو المساعده فى جعل الشيت يقوم بحفظ جميع الشبتات pdf

دون تسميتها ...

Sheets(Array("رمضان 1", "رمضان 2", "رمضان 3", "رمضان 4")).Select

حتى لا اكون مجبر الى اضافة اسم اى شيت اخر الى الكود 

 

 

Sub PDF_ALL()

Application.ScreenUpdating = False

    On Error Resume Next

      ActiveSheet.Unprotect "2191612"

 MyName = "D:\تايم شبت المقاولين_" & Format(Date, "dd-mm-yyyy") & ".pdf"

    Range("C45").Select

    Sheets(Array("رمضان 1", "رمضان 2", "رمضان 3", "رمضان 4")).Select

    Sheets("رمضان 1").Activate

     MyMsg = MsgBox("هل انت متاكد من اتمام عمليه الحفظ", 4, "تنبيه")

    If MyMsg = 6 Then

    ChDir "D:"

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _

        MyName, Quality:=xlQualityStandard, _

        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:= _

        True

    MsgBox "تم الحفظ"

    Else

       MsgBox "لم يتم الحفظ"

        End If

        Application.ScreenUpdating = True

    Sheets("رمضان 1").Select

    ActiveSheet.Unprotect "2191612"

End Sub

 

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

المقاولين1.rar

تم تعديل يناير 2, 2015 بواسطه ۩◊۩ أبو حنين ۩◊۩

[ياسر خليل أبو البراء]

حبذا لو ترفق ملف أخي أبو حنين

بارك الله فيك

[۩◊۩ أبو حنين ۩◊۩]

اخى ياسر 

تم ارفاق الملف فى المشاركة رقم 1

[علي المصري]

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

انا بستخدم الكود التالي مع الوظيفة المعرفة

انسخ الكود التالي مع تغيير اسماء الاوارق حسب ما هو موجود عندك

sub SavePdf()
On Error Resume Next
      Dim FileName As String
    Dim rng As Range
    On Error Resume Next
        Set rng = Range(Sheets("AliElbasry").PageSetup.PrintArea)
    If Not rng Is Nothing Then
        Debug.Print rng.Address(external:=True)
    rng.Select
    FileName = RDB_Create_PDF(Sheets("AliElbasry"), "", True, True)
        If FileName = "" Then
        Else
        Sheets("Data").Select
          Range("D3:L3").Select
           Exit Sub
           
        End If
            End If
        Sheets("Data").Select
          Range("D3:L3").Select
End Sub





مع الوظيفة التالية

 

انسخ وضوعها في موديول جديد

Function RDB_Create_PDF(Myvar As Object, FixedFilePathName As String, _
                        OverwriteIfFileExist As Boolean, OpenPDFAfterPublish As Boolean) As String
    Dim FileFormatstr As String
    Dim Fname As Variant

    If Dir(Environ("commonprogramfiles") & "\Microsoft Shared\OFFICE" _
         & Format(Val(Application.Version), "00") & "\EXP_PDF.DLL") <> "" Then

        If FixedFilePathName = "" Then
            FileFormatstr = "PDF Files (*.pdf), *.pdf"
            Fname = Application.GetSaveAsFilename("", filefilter:=FileFormatstr, _
                                                  Title:="Create PDF")

            If Fname = False Then Exit Function
        Else
            Fname = FixedFilePathName
        End If

        If OverwriteIfFileExist = False Then
            If Dir(Fname) <> "" Then Exit Function
        End If

        On Error Resume Next
        Myvar.ExportAsFixedFormat _
                Type:=xlTypePDF, _
                FileName:=Fname, _
                Quality:=xlQualityStandard, _
                IncludeDocProperties:=True, _
                IgnorePrintAreas:=False, _
                OpenAfterPublish:=OpenPDFAfterPublish
        On Error GoTo 0

        If Dir(Fname) <> "" Then RDB_Create_PDF = Fname
    End If
End Function

[عبد الله بولنوار]

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

 

هذا ا فهمته

 

 

جرب هذا

المقاولين1.rar

تم تعديل يناير 2, 2015 بواسطه عبد الله بولنوار

[عبد الله بولنوار]

او هذا بعد ظبط ناحية الطباعة

 

و اخراج الايقونات من الطباعة

 

 

المقاولين1.rar

[بن علية حاجي]

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

 

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

 

أخوك بن علية

 

الملف المرفق : المقاولين1.rar

[علي المصري]

هي يمكن التعديل بحيث يخرج مربع حواري تختار منه المكان الذي تريد الحفظ فيه

شكرا

[۩◊۩ أبو حنين ۩◊۩]

السلام عليكم

الاخ الكريم على المصرى ... جزاك الله كل خير على وقتك وسعيك وحلولك 

الاخ الكريم عبد الله جزاك الله كل الخير عى اضافتك الجميلة

الاخ الكبير مقاما وقيمة بن علية حاجى ... سلمت يداك بكل خير

هذا هو المطلوب فعلا ... جزاك الله كل الخير  ...

لقد حاولت تتبع عمك فى ملف الطباعه محاولا تطبيق الشرط نفسة ...

الا انه كانت تظهر اخطاء .. لا اعلم كيف التعامل معاها

جزاك الله خيرا ولجميع الاخوه فى المتدى وجعلة الله فى ميزان حسناتكم

تم تعديل يناير 2, 2015 بواسطه ۩◊۩ أبو حنين ۩◊۩