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 = 0
    Do While myfile <> "" '不为空的时候 往下循环
        k = k + 1
        a(k) = myfile '写入第一个文件
        myfile = Dir
    Loop
    MkDir a2 & "\转换后\"
    For i = 1 To 1000
    If a(i) <> "" And a(i) <> "批量转换成PDF.xlsm" Then
     Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Workbooks.Open Filename:=a2 & "\" & a(i)
    Set wb = ActiveWorkbook
    Na = a(i)
    gw = Left(Na, Application.Find(".", Na) - 1) & ".pdf"
    Workbooks(Na).ExportAsFixedFormat Type:=xlTypePDF, Filename:=a2 & "\转换后\" & gw, Quality:=xlQualityStandard
    wb.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Else
    Exit For
    End If
    Next 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


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112