تعديل كود ليقوم بتحديد صفحات بدل من طباعة كل الصفحات

[salimhebboul]

الكود من عمل الاستاذ  الرائد   اريد من خلاله طباعة 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

[الرائد77]

غير في  هذا السطر

For i = 1 To Sheets.Count

حييث 1 يمثل الورقة 1 

مثلا 

For i = 2 To 5

اي من الورقة 2 الى الورقة 5

غير حسب ما تريد

 

 

[salimhebboul]

الف شكر لك ااستاذي 

ممتن جدا لك  استطعنا تحديد الاوراق 

لكني وجدت مشكلة في الكود الاصلي عند طباعة الاوراق تطبع الورقة النشطة فقط وتأخذ أسماء الاوراق الاخرى  وهو مالم ننتبه له في الكود الاصلي  

[الرائد77]

تم التعديل. استبدل الكود السابق بهذا

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

[salimhebboul]

الف شكر لك استاذي

[abdel_madjid]

السلام عليكم اخي لم تنجح معي هذه الطريقة