Sub 批量另存为()
Application.ScreenUpdating = False
Dim pppath, xlsht, xlwb, xlpath, m, n, i
d = ThisWorkbook.Path
Dim a
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0, "选择文件夹", 0, 0)
If Not objFolder Is Nothing Then
a = objFolder.self.Path
End If
Set objFolder = Nothing
Set objShell = Nothing
Dim b, c
c = 0
For Each f In CreateObject("scripting.FileSystemObject").GetFolder(a).Files
If f.Name Like "*.xls" Then c = c + 1
Workbooks.Open Filename:=f, UpdateLinks:=0
ActiveWorkbook.SaveAs Filename:=d & "\" & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4), FileFormat:=xlOpenXMLWorkbook
ActiveWindow.Close
Next
If c = 0 Then
MsgBox "该文件夹内无xlsx格式的文件"
Exit Sub
End If
Application.ScreenUpdating = True
End Sub