EXCEL使用VBA一键批量转换成PDF

EXCEL使用VBA一键批量转换成PDF

上图是给定转换路径

Sub 按钮1_Click()
Dim a(1 To 1000) As String
Dim a2 As String
Dim myfile As String
Dim wb As Workbook
a2 = Trim(Range("a2"))myfile = Dir(a2 & "\" & "*.xls")k = 0Do While myfile <> "" '不为空的时候 往下循环k = k + 1a(k) = myfile '写入第一个文件myfile = DirLoopMkDir a2 & "\转换后\"For i = 1 To 1000If a(i) <> "" And a(i) <> "批量转换成PDF.xlsm" ThenApplication.DisplayAlerts = FalseApplication.ScreenUpdating = FalseWorkbooks.Open Filename:=a2 & "\" & a(i)Set wb = ActiveWorkbookNa = a(i)gw = Left(Na, Application.Find(".", Na) - 1) & ".pdf"Workbooks(Na).ExportAsFixedFormat Type:=xlTypePDF, Filename:=a2 & "\转换后\" & gw, Quality:=xlQualityStandardwb.CloseApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueElseExit ForEnd IfNext i
End Sub
'Sub ExportToPDF()
'
'Dim Arr, Str1, Str2, Shp, myPath1, myPath2, MyPos, Na, Sh, i1, i2
'
'On Error Resume Next               '忽略运行中可能出现的错误
'
'Application.ScreenUpdating = False '关闭工作表更新，提高运行速度
'
'Application.DisplayAlerts = False  '忽略报警提示
'
'Arr = Array(".xls", ".xlsx", ".xlsm")  'Excel格式集合
'
'myPath1 = "C:\Users\Andre\Desktop\批量转换PDF\"        '源文件路径
'
'myPath2 = myPath1 & "EFGH\"  '导出路径
'
'MkDir myPath2                '新建文件夹
'
'Set fs = CreateObject("Scripting.FileSystemObject") '计算机文件访问
'
'Set fo = fs.GetFolder(myPath1)  '获取文件夹
'
'
'
'For Each fi In fo.Files  '扫描文件夹里面的每一个文件
'
' i1 = 0
'
' i2 = 0
'
' Na = fi.Name  '获取文件名称
'
' Do
'
'  i1 = MyPos   '寄存上次获取“.”的位置
'
'  i2 = i2 + 1
'
'  MyPos = InStr(MyPos + 1, Na, ".") '获取"."存在的位置
'
'  If MyPos = 0 And i2 <> 1 Then
'
'   Str1 = Right(Na, Len(Na) - i1 + 1) '截取后缀名
'
'   Str2 = Left(Na, i1 - 1) & ".pdf"   '生成新的PDF文件名称
'
'   'If UBound(Filter(Arr, Str1)) = 0 Then  '如果是Excel格式的文件，则
'
'    Workbooks.Open Filename:=myPath1 & Na '打开Excel文件
'
'    For Each Sh In Workbooks(Na).Sheets   '扫描每张工作表
'
'     Sh.PageSetup.Zoom = 80  '工作表打印区域设定成80%
'
'    Next
'
'    Workbooks(Na).ExportAsFixedFormat Type:=xlTypePDF, Filename:=myPath2 & Str2, Quality:=xlQualityStandard
'
'    '输出PDF文件
'
'    Workbooks(Na).Close '关闭工作表
'
'   'End If
'
'   Exit Do  '退出Do循环
'
'  End If
'
' Loop
'
'Next
'
'Application.DisplayAlerts = True   '恢复报警提示
'
'Application.ScreenUpdating = True  '恢复更新显示
'
'
'
'End Sub