#1
Mümkün müdür
@benbendedeilem
Vba Kodu İle Exceli Pdf Ye Çevirmek
#1
Excelin neyini çevireceksiniz.Tüm sayfalarımı,belirli sayfalarımı?
Konu hakkınca bence yüzlerce örnek vardır internet deryasında.
Konu hakkınca bence yüzlerce örnek vardır internet deryasında.
Pdf olarak saklayacağım ama exceldeki yerleşim bozulmadan yapmak istiyorum
Print Selection To PDF
Print One Table To PDF
Print All Tables To Separate PDFs
Print All Sheets To One PDF
Print Chart Sheets To PDF
Print Chart Objects To PDF
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 SubPrint 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 SubPrint 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 SubPrint 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 SubPrint 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 SubPrint 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
DynamicMenu.zip
(Dosya Boyutu: 44,05 KB | İndirme Sayısı: 4)
@benbendedeilem
Konuyu Okuyanlar: 1 Ziyaretçi
