Skip to main content

AccessTr.neT


Vba Kodu İle Exceli Pdf Ye Çevirmek

Vba Kodu İle Exceli Pdf Ye Çevirmek

Çözüldü #1
Mümkün müdür
@benbendedeilem
Cevapla
#2
Excelin neyini çevireceksiniz.Tüm sayfalarımı,belirli sayfalarımı?

Konu hakkınca bence yüzlerce örnek vardır internet deryasında.
Cevapla
#3
Pdf olarak saklayacağım ama exceldeki yerleşim bozulmadan yapmak istiyorum

Print Selection To PDF

Kod:
Sub PrintSelectionToPDF()
'SUBROUTINE: PrintSelectionToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Print your currently selected range to a PDF

Dim ThisRng As Range
Dim strfile As String
Dim myfile As Variant

If Selection.Count = 1 Then
Set ThisRng = Application.InputBox("Select a range", "Get Range", Type:=8)
Else
Set ThisRng = Selection
End If
'Prompt for save location
strfile = "Selection" & "_" _
& Format(Now(), "yyyymmdd_hhmmss") _
& ".pdf"
strfile = ThisWorkbook.Path & "\" & strfile

myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")

If myfile <> "False" Then 'save as PDF
ThisRng.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "No File Selected. PDF will not be saved", vbOKOnly, "No File Selected"
End If

End Sub


Print One Table To PDF

Kod:
Sub PrintTableToPDF()
'SUBROUTINE: PrintTableToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Print a table of your choosing to a PDF

Dim strfile As String
Dim myfile As Variant
Dim strTable As String, r As Range
Application.ScreenUpdating = False

'Enter the table name you want to save
strTable = InputBox("What's the name of the table you want to save?", "Enter Table Name") 'Table you want to save
If Trim(strTable) = "" Then Exit Sub
'Prompt for save location
strfile = strTable & "_" _
& Format(Now(), "yyyymmdd_hhmmss") _
& ".pdf"
strfile = ThisWorkbook.Path & "\" & strfile

myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")

If myfile <> "False" Then 'save as PDF
Range(strTable).ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "No File Selected. PDF will not be saved", vbOKOnly, "No File Selected"
End If

Application.DisplayAlerts = False

LetsContinue:
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
End Sub


Print All Tables To Separate PDFs

Kod:
Sub PrintAllTablesToPDFs()
'SUBROUTINE: PrintAllTablesToPDFs
'DEVELOPER: Ryan Wells
'DESCRIPTION: Print each table in your spreadsheet to a different PDF
Dim strTables() As String
Dim strfile As String
Dim ch As Object, sh As Worksheet
Dim icount As Integer
Dim myfile As Variant
Dim tbl As ListObject
Dim sht As Worksheet

With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Where do you want to save your PDF?"
.ButtonName = "Save Here"
.InitialFileName = ThisWorkbook.Path
If .Show = -1 Then ' if OK is pressed
sfolder = .SelectedItems(1)
Else
End
End If
End With

For Each sht In ThisWorkbook.Worksheets
For Each tbl In sht.ListObjects
myfile = ThisWorkbook.Name & "" & tbl.Name & "" _
& Format(Now(), "yyyymmdd_hhmmss") _
& ".pdf"
myfile = sfolder & "\" & myfile
sht.Range(tbl.Name).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Next tbl
Next sht

End Sub


Print All Sheets To One PDF

Kod:
Sub PrintAllSheetsToPDF()
'SUBROUTINE: PrintAllSheetsToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Combine all your worksheets into one PDF
Dim strSheets() As String
Dim strfile As String
Dim sh As Worksheet
Dim icount As Integer
Dim myfile As Variant

'Save Chart Sheet names to an Array
For Each sh In ActiveWorkbook.Worksheets
If sh.Visible = xlSheetVisible Then
ReDim Preserve strSheets(icount)
strSheets(icount) = sh.Name
icount = icount + 1
End If
Next sh

If icount = 0 Then 'No charts found. Punch error
MsgBox "A PDF cannot be created because no sheets were found.", , "No Sheets Found"
Exit Sub
End If

'Prompt for save location
strfile = "Sheets" & "_" _
& Format(Now(), "yyyymmdd_hhmmss") _
& ".pdf"
strfile = ThisWorkbook.Path & "\" & strfile

myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")

If myfile <> "False" Then 'save as PDF
ThisWorkbook.Sheets(strSheets).Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "No File Selected. PDF will not be saved", vbOKOnly, "No File Selected"
End If

End Sub


Print Chart Sheets To PDF

Kod:
Sub PrintChartSheetsToPDF()
'SUBROUTINE: PrintChartSheetsToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Combine all chart sheets into one PDF

Dim strSheets() As String
Dim strfile As String
Dim ch As Object, sh As Worksheet
Dim icount As Integer
Dim myfile As Variant

'Save Chart Sheet names to an Array
For Each ch In ActiveWorkbook.Charts
ReDim Preserve strSheets(icount)
strSheets(icount) = ch.Name
icount = icount + 1
Next ch

If icount = 0 Then 'No charts found. Punch error
MsgBox "A PDF cannot be created because no Chart Sheets were found.", , "No Chart Sheets Found"
Exit Sub
End If

'Prompt for save location
strfile = "Charts" & "_" _
& Format(Now(), "yyyymmdd_hhmmss") _
& ".pdf"
strfile = ThisWorkbook.Path & "\" & strfile

myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")

If myfile <> "False" Then 'save as PDF
ThisWorkbook.Sheets(strSheets).Select

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
myfile, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=True
Else
MsgBox "No File Selected. PDF will not be saved", vbOKOnly, "No File Selected"
End If

End Sub


Print Chart Objects To PDF

Kod:
Sub PrintChartsObjectsToPDF()
'SUBROUTINE: PrintChartsObjectsToPDF
'DEVELOPER: Ryan Wells
'DESCRIPTION: Combine all chart objects into one PDF

Dim ws As Worksheet, wsTemp As Worksheet
Dim chrt As ChartObject
Dim tp As Long
Dim strfile As String
Dim myfile As Variant

Application.ScreenUpdating = False

Set wsTemp = Sheets.Add

tp = 10

With wsTemp
For Each ws In ActiveWorkbook.Worksheets
If ws.Name = wsTemp.Name Then GoTo nextws:
For Each chrt In ws.ChartObjects
chrt.Copy
wsTemp.Range("A1").PasteSpecial
Selection.Top = tp
Selection.Left = 5
If Selection.TopLeftCell.Row > 1 Then
ActiveSheet.Rows(Selection.TopLeftCell.Row).PageBreak = xlPageBreakManual
End If
tp = tp + Selection.Height + 50
Next
nextws:
Next ws
End With

'Prompt for save location
strfile = "Charts" & "_" _
& Format(Now(), "yyyymmdd\_hhmmss") _
& ".pdf"
strfile = ActiveWorkbook.Path & "\" & strfile

myfile = Application.GetSaveAsFilename _
(InitialFileName:=strfile, _
FileFilter:="PDF Files (*.pdf), *.pdf", _
Title:="Select Folder and File Name to Save as PDF")

If myfile <> False Then 'save as PDF
wsTemp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myfile, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
'Else
' MsgBox "No File Selected. PDF will not be saved", vbOKOnly, "No File Selected"
End If

Application.DisplayAlerts = False
wsTemp.Delete

With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
Exit Sub
End Sub


.zip DynamicMenu.zip (Dosya Boyutu: 44,05 KB | İndirme Sayısı: 3)
@benbendedeilem
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da