salimhebboul قام بنشر مايو 23, 2020 مشاركة قام بنشر مايو 23, 2020 الكود من عمل الاستاذ الرائد اريد من خلاله طباعة 3 اوراق عمل فقط الى pdf وليس كل الصفحات لتعذر حذف بعض الثفحات Sub pdfcopy2() Application.Calculation = xlCalculationAutomatic Application.DisplayStatusBar = False Application.EnableEvents = False Dim wsA As Worksheet Dim wbA As Workbook Dim strName As String Dim strPath As String Dim strFile As String Dim strPathFile As String Dim myFile As Variant Dim lOver As Long On Error GoTo errHandler Set wbA = ActiveWorkbook Set wsA = ActiveSheet strPath = ThisWorkbook.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" For i = 1 To Sheets.Count If i <> "" Then strName = i & "-" & Sheets(i).Name & "-" & ActiveSheet.Range("b3").Value strFile = strName & ".pdf" strPathFile = strPath & strFile If bFileExists(strPathFile) Then lOver = MsgBox("الملف موجود مسبقا.هل تريد استبداله؟", _ vbQuestion + vbYesNo, "ملف موجود") If lOver <> vbYes Then myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="PDF Files (*.pdf), *.pdf", _ Title:="إختيار مجلد الحفظ") If myFile <> "False" Then strPathFile = myFile Else GoTo exitHandler End If End If End If wsA.ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=strPathFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End If Next i MsgBox "تم إنشاء الملف بإسم المعني: " & vbCrLf & strPathFile errHandler: Resume exitHandler exitHandler: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True End Sub 17.xlsm رابط هذا التعليق شارك More sharing options...
الرائد77 قام بنشر مايو 23, 2020 مشاركة قام بنشر مايو 23, 2020 غير في هذا السطر For i = 1 To Sheets.Count حييث 1 يمثل الورقة 1 مثلا For i = 2 To 5 اي من الورقة 2 الى الورقة 5 غير حسب ما تريد 2 رابط هذا التعليق شارك More sharing options...
salimhebboul قام بنشر مايو 24, 2020 الكاتب مشاركة قام بنشر مايو 24, 2020 الف شكر لك ااستاذي ممتن جدا لك استطعنا تحديد الاوراق لكني وجدت مشكلة في الكود الاصلي عند طباعة الاوراق تطبع الورقة النشطة فقط وتأخذ أسماء الاوراق الاخرى وهو مالم ننتبه له في الكود الاصلي رابط هذا التعليق شارك More sharing options...
أفضل إجابة الرائد77 قام بنشر مايو 26, 2020 أفضل إجابة مشاركة قام بنشر مايو 26, 2020 تم التعديل. استبدل الكود السابق بهذا Sub pdfcopy2() Application.Calculation = xlCalculationAutomatic Application.DisplayStatusBar = False Application.EnableEvents = False Dim wsA As Worksheet Dim wbA As Workbook Dim strName As String Dim strPath As String Dim strFile As String Dim strPathFile As String Dim myFile As Variant Dim lOver As Long On Error GoTo errHandler Set wbA = ActiveWorkbook Set wsA = ActiveSheet strPath = ThisWorkbook.Path If strPath = "" Then strPath = Application.DefaultFilePath End If strPath = strPath & "\" For i = 2 To 4 If i <> "" Then strName = i & "-" & Sheets(i).Name & "-" & Sheets(i).Range("b3").Value strFile = strName & ".pdf" strPathFile = strPath & strFile If bFileExists(strPathFile) Then lOver = MsgBox("ÇáãáÝ ãæÌæÏ ãÓÈÞÇ.åá ÊÑíÏ ÇÓÊÈÏÇáå¿", _ vbQuestion + vbYesNo, "ãáÝ ãæÌæÏ") If lOver <> vbYes Then myFile = Application.GetSaveAsFilename _ (InitialFileName:=strPathFile, _ FileFilter:="PDF Files (*.pdf), *.pdf", _ Title:="ÅÎÊíÇÑ ãÌáÏ ÇáÍÝÙ") If myFile <> "False" Then strPathFile = myFile Else GoTo exitHandler End If End If End If Sheets(i).ExportAsFixedFormat _ Type:=xlTypePDF, _ Filename:=strPathFile, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False End If Next i MsgBox "Êã ÅäÔÇÁ ÇáãáÝ ÈÅÓã ÇáãÚäí: " & vbCrLf & strPathFile errHandler: Resume exitHandler exitHandler: Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True Application.DisplayStatusBar = True Application.EnableEvents = True End Sub 17 (1).xlsm 1 رابط هذا التعليق شارك More sharing options...
salimhebboul قام بنشر مايو 28, 2020 الكاتب مشاركة قام بنشر مايو 28, 2020 الف شكر لك استاذي رابط هذا التعليق شارك More sharing options...
abdel_madjid قام بنشر سبتمبر 20, 2020 مشاركة قام بنشر سبتمبر 20, 2020 السلام عليكم اخي لم تنجح معي هذه الطريقة رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان