EXCEL Dosyasını Pdf Çevirme

[efem67]

Merhabalar ;
macroyu çalıştırdığımda tek sayfa olarak çevirmiyor
macroda bir hatamı yaptım acaba;
Sub PDF_YAP()
'
' PDF_YAP Makro
'
Kaynak = ThisWorkbook.Path & "\YSONUCLAR\"

dosya_adı = ActiveWorkbook.Sheets("HAKEMSONUC").Select
Range("A1:BJ31").Select


NO_YIL = Sheets("HAKEMSONUC").Range("AY5").Value
NO_0 = Sheets("HAKEMSONUC").Range("F5").Value
NO_1 = Sheets("HAKEMSONUC").Range("AF5").Value
NO_2 = Sheets("HAKEMSONUC").Range("AF6").Value
NO_3 = Sheets("HAKEMSONUC").Range("F6").Value

' strdate = Format(Now, "yyyy")

Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Kaynak & NO_YIL & " " & "Yılı (" & NO_0 & " " & NO_1 & " " & NO_2 & " " & " " & NO_3 & " " & ")Sonuç Tutanağı", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

' ActiveWorkbook.Save '
' ActiveWindow.Close '

MsgBox "Sonuç " & vbLf & "YSONUCLAR Klasörüne" & vbLf & "PDF olarak Kaydoldu" & vbLf & "Copyrigh: excel vba"
Sheets("SayfaANA").Select
Range("B11").Select
ActiveCell.FormulaR1C1 = "1"
Range("B11").Select
Selection.Copy
Range("B12").Select
ActiveSheet.Paste
Application.CutCopyMode = True

End Sub

 

[efem67]

KONU Günceldir..

 

[PLİNT]

Merhaba
Sayfayı pdf ye çevirirken yazdırma alanı belirleme gibi düşünün
"A:BJ" sütunu bayağı sayfa gerektiriyor bu sütunların hepsinde verileriniz varmı?.

dosya_adı = ActiveWorkbook.Sheets("HAKEMSONUC").Select
Range("A1:[COLOR="Red"]BJ31[/COLOR]").Select

 

[efem67]

Evet Hocam tümünde veriler mevcut..

 

[efem67]

Birde bu ekteki macroyu buldum düzgün çalışıyor ama bana kayıt ederken klasör ve yatamı dikeymi diye sormadan
otomatık \YSNUCLAR\ klasörüne kayıt etmesini istiyorum.

Sub AKTİF_SAYFAYI_PDF_KAYDET()
Dim Dosya_Adi As String, Yol As String, Sayfa_Yonu As Byte
Dim Onay_Yatay As Byte, Kayit_Yeri As Object
Dim K1 As Workbook, S1 As Worksheet, S2 As Worksheet
Set Kayit_Yeri = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen dosyanızı kayıt etmek istediğiniz bölümü seçiniz !", 1)
If Not Kayit_Yeri Is Nothing Then
Yol = Kayit_Yeri.Self.Path & "\"
Else
MsgBox "Kayıt etmek istediğiniz bölümü seçmediğiniz için işleminiz iptal edilmiştir.", vbExclamation
Exit Sub
End If

Dosya_Adi = Yol & ActiveSheet.Name & " " & Format(Date, "ddmmyyyy") & "_" & Format(Time, "hhmm") & ".pdf"

Set K1 = ThisWorkbook
Set S1 = K1.ActiveSheet
S1.Copy , K1.Worksheets(K1.Worksheets.Count)
Set S2 = ActiveSheet

Sayfa_Yonu = S2.PageSetup.Orientation

If Onay_Yatay = vbYes Then
S2.PageSetup.Orientation = 1

End If

With S2.PageSetup
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.393700787401575)
.FooterMargin = Application.InchesToPoints(0.393700787401575)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1


S2.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Dosya_Adi, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True

Application.DisplayAlerts = False
S2.Delete
Application.DisplayAlerts = True

MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation


End With
End Sub

 

[efem67]

Dosya adınıda daha önce eklediğim.
istediğim yerlerdeki isimleri almasını yapamadım..
Hata verdi..

Kaynak = ThisWorkbook.Path & "\YSONUCLAR\"

dosya_adı = ActiveWorkbook.Sheets("HAKEMSONUC").Select
Range("A1:BJ31").Select


NO_YIL = Sheets("HAKEMSONUC").Range("AY5").Value
NO_0 = Sheets("HAKEMSONUC").Range("F5").Value
NO_1 = Sheets("HAKEMSONUC").Range("AF5").Value
NO_2 = Sheets("HAKEMSONUC").Range("AF6").Value
NO_3 = Sheets("HAKEMSONUC").Range("F6").Value

' strdate = Format(Now, "yyyy")

Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Kaynak & NO_YIL & " " & "Yılı (" & NO_0 & " " & NO_1 & " " & NO_2 & " " & " " & NO_3 & " " & ")Sonuç Tutanağı", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True

 

[PLİNT]

Sizin kodlarınızda Pdf ye çevireceğiniz sayfayı yazdırma seçeneklerinden "sığdır" ve "yatay" olarak ayarlayıp yapabilirdiniz.

Son eklediğiniz kodlar önceki kodlarınızdaki ad ve adrese göre aşağıdaki gibi düzenlenebilir (Kırmızı bölüm 1 dikey, 2 yatay)

[SIZE="2"]Sub PDF_YAP()
Dim Dosya_Adi As String, Yol As String, Sayfa_Yonu As Byte
Dim Onay_Yatay As Byte, Kayit_Yeri As Object
Dim K1 As Workbook, S1 As Worksheet, S2 As Worksheet

Yol = ThisWorkbook.Path & "\YSONUCLAR\"
NO_YIL = Sheets("HAKEMSONUC").Range("AY5").Value
NO_0 = Sheets("HAKEMSONUC").Range("F5").Value
NO_1 = Sheets("HAKEMSONUC").Range("AF5").Value
NO_2 = Sheets("HAKEMSONUC").Range("AF6").Value
NO_3 = Sheets("HAKEMSONUC").Range("F6").Value
Application.ScreenUpdating = False
Set K1 = ThisWorkbook
Set S1 = K1.Sheets("HAKEMSONUC")
Sheets.Add After:=Sheets(Sheets.Count)
S1.Range("A1:BJ31").Copy K1.Worksheets(K1.Worksheets.Count).Cells(1)
Set S2 = ActiveSheet
S2.PageSetup.Orientation = [COLOR="Red"]2[/COLOR]
With S2.PageSetup
.LeftMargin = Application.InchesToPoints(0.393700787401575)
.RightMargin = Application.InchesToPoints(0.393700787401575)
.TopMargin = Application.InchesToPoints(0.393700787401575)
.BottomMargin = Application.InchesToPoints(0.393700787401575)
.HeaderMargin = Application.InchesToPoints(0.393700787401575)
.FooterMargin = Application.InchesToPoints(0.393700787401575)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
S2.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Yol & NO_YIL & " " & "Yılı (" & NO_0 & " " & NO_1 & " " & NO_2 & " " & " " & NO_3 & " " & ")Sonuç Tutanağı", Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Application.ScreenUpdating = True  'veya false pdf açılmasın '.................
Application.DisplayAlerts = False
S2.Delete
Application.DisplayAlerts = True
MsgBox "Kayıt işlemi tamamlanmıştır.", vbInformation
End With
End Sub[/SIZE]

 

[efem67]

Hocam Çok Teşekkür ederim..
Mükemmel Emeğinzie Sağlık...