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 & "\zhh\"
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, 10 + i) & ".pdf"
Workbooks(Na).ExportAsFixedFormat Type:=xlTypePDF, Filename:=a2 & "\zhh\" & gw, Quality:=xlQualityStandard
wb.Close
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Else
Exit For
End If
Next i
Application.DisplayAlerts = True
Application.ScreenUpdating = True
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
