Macro ile Excel Sayfalarını PDF Yapıp Yazdırmak

[alper2323]

Merhaba;

Oluşturduğum Excel dosyasında yer alan 4 sayfayı öncelikle PDF' e dönüştürüp desktop' uma kaydedip (cntrl+n ile) daha sonra farklı bir kısayol ile (ctrl+m ile) tıklayarak yazdırmak istiyorum. Rica etsem bu konuda bana bir macro kodu yazabilir misiniz? Örnek amaçlı dosyayı ekte iletiyorum.

Teşekkürler

 

[halit3]

Bir userform oluştur userformun üstüne
ListBox1
CommandButton1
CheckBox1

bu nesneleri ekle ve aşağıdaki kodu userformun kod bölümüne ekle ve listeden sayfaları seç kaomut düğmesini tıkla

Private Sub CheckBox1_Click()
Dim i As Integer
For i = 0 To ListBox1.ListCount - 1
ListBox1.Selected(i) = CheckBox1.Value
Next
End Sub


Private Sub CommandButton1_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

say1 = 0

Dim i As Integer
son = 0
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
son = 1
Exit For
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If

For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then

If WorksheetFunction.CountA(ThisWorkbook.Sheets(ListBox1.List(i)).Cells) > 0 Then
Else
GoTo atla1
End If
say1 = say1 + 1
If say1 = 1 Then
ThisWorkbook.Sheets(ListBox1.List(i)).Copy

ActiveSheet.DrawingObjects.Delete
Else
ThisWorkbook.Sheets(ListBox1.List(i)).Copy After:=ActiveWorkbook.Sheets(1)
say = ActiveWorkbook.Sheets.Count
Sheets(ActiveSheet.Name).Move After:=Sheets(say)
ActiveSheet.DrawingObjects.Delete

End If
atla1:
End If
Next

If say1 > 0 Then
ActiveWorkbook.Worksheets.Select

ad = ThisWorkbook.Path & "\pdf dosyası"
If CreateObject("Scripting.FileSystemObject").FolderExists(ad) = False Then
MkDir ad
End If

say = CreateObject("Scripting.FileSystemObject").getfolder(ad).Files.Count + 1

Dosya = CreateObject("Scripting.FileSystemObject").GetBaseName(ThisWorkbook.Name)

ActiveWorkbook.Sheets(1).ExportAsFixedFormat Type:=xlTypePDF, Filename:=ad & "\" & Dosya & say & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

ActiveWorkbook.Close False
End If
MsgBox "İşlem Tamam", vbInformation, " U Y A R I "
End Sub

Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1
For i = 1 To ActiveWorkbook.Sheets.Count
ListBox1.AddItem Sheets(i).Name

Next i
End Sub