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