时间:2017-06-13 17:03:37
利用VBA把一个文件中的多个 Sheet转到一个PDF文件,其原理就是同时选择要导出生成的sheet,然后另存为PDF(2007以上版本才可以2003版本不行)
以下是完整代码
Sub 批转PDF()
'
' 批转PDF 宏
If Application.Version < 12 Then
MsgBox "此功能用于Excel2007以上"
Exit Sub
End If
'
If MsgBox("确认要所有不含NO的工作表转成到一个PDF文件吗?", vbOKCancel, "温馨提示") = vbCancel Then
End
End If
Dim MyStr() As String
Dim Sht As Worksheet
Dim nnn As Integer
nnn = 0
For Each Sht In ThisWorkbook.Worksheets
If Sht.Name <> "基本信息" And Sht.Name <> "通信线缆" And Sht.Name <> "电力电缆" And Sht.Name <> "服务费明细" And (InStr(Sht.Name, "NO") = 0 And InStr(Sht.Name, "no") = 0) Then
' Debug.Print Sht.Name
nnn = nnn + 1
ReDim Preserve MyStr(nnn - 1)
MyStr(nnn - 1) = Sht.Name
If Sht.Name <> "表一" And Sht.Name <> "表二" And Sht.Name <> "表五" Then
With Worksheets(Sht.Index).PageSetup
'第&[页码]页,共&[总页数]页
If Worksheets(Sht.Index).PageSetup.Pages.Count > 1 Then
.RightHeader = "&""仿宋_GB2312,常规""&10第&P页,共" & Worksheets(Sht.Index).PageSetup.Pages.Count & "页"
Else
.RightHeader = "&""仿宋_GB2312,常规""&10第全页"
End If
End With
End If
End If
Next
Sheets(MyStr).Select '选择SHEET
' Debug.Print ThisWorkbook.FullName
' Set fs = CreateObject("Scripting.FileSystemObject") '
' Debug.Print fs.GetbaseName(ThisWorkbook.FullName) '不带扩展名的文件名
' Debug.Print fs.GetExtensionname(ThisWorkbook.FullName) '扩展名
' Debug.Print ThisWorkbook.Path
'另存为
Set fs = CreateObject("Scripting.FileSystemObject") '
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\" & fs.GetbaseName(ThisWorkbook.FullName) & ".PDF", Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Sheets(Array("基本信息")).Select
Application.StatusBar = "PDF文件已输出至本文档目录下!"
End Sub