اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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


إذهب إلى أفضل إجابة Solved by الرائد77,

الردود الموصى بها

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

رابط هذا التعليق
شارك

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

For i = 1 To Sheets.Count

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

مثلا 

For i = 2 To 5

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

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

 

 

  • Like 2
رابط هذا التعليق
شارك

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

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

لكني وجدت مشكلة في الكود الاصلي عند طباعة الاوراق تطبع الورقة النشطة فقط وتأخذ أسماء الاوراق الاخرى  وهو مالم ننتبه له في الكود الاصلي 1.png.8d2dfca7c3ee2c1315347dff169b26df.png2.png.65725b4980642b34ddc77d89ab07fe05.png 

رابط هذا التعليق
شارك

  • أفضل إجابة

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

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

  • Like 1
رابط هذا التعليق
شارك

  • 3 months later...

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information