Excelmacros将xlsx转换为xls

我有一堆文件夹中的所有文件都是xlsx格式，我需要将它们转换为xls格式。 这将在日常的基础上完成。

我需要一个macros，它将围绕文件夹循环，并将文件转换为xlsx的xls而不更改文件名。

这是我用来循环的macros

 Sub ProcessFiles() Dim Filename, Pathname As String Dim wb As Workbook Pathname = ActiveWorkbook.Path & "C:\Users\myfolder1\Desktop\myfolder\Macro\" Filename = Dir(Pathname & "*.xls") Do While Filename <> "" Set wb = Workbooks.Open(Pathname & Filename) DoWork wb wb.Close SaveChanges:=True Filename = Dir() Loop End Sub 

Answer 1

你所缺less的是，而不是调用wb.Close SaveChanges=True以另一种格式保存文件，你需要调用wb.SaveAs与新的文件格式和名称。

你说你想在不改变文件名的情况下转换它们，但是我怀疑你的意思是你想要用相同的基本文件名保存它们，但是扩展名是.xls 。 因此，如果工作簿名为book1.xlsx ， book1.xlsx将其保存为book1.xls 。 要计算新名称，可以使用.xlsreplace.xlsx扩展名，replace旧名称中的Replace() 。

您还可以通过设置wb.CheckCompatibility禁用兼容性检查器，并通过设置Application.DisplayAlerts禁止警报和消息。

 Sub ProcessFiles() Dim Filename, Pathname, saveFileName As String Dim wb As Workbook Dim initialDisplayAlerts As Boolean Pathname = "<insert_path_here>" ' Needs to have a trailing \ Filename = Dir(Pathname & "*.xlsx") initialDisplayAlerts = Application.DisplayAlerts Application.DisplayAlerts = False Do While Filename <> "" Set wb = Workbooks.Open(Filename:=Pathname & Filename, _ UpdateLinks:=False) wb.CheckCompatibility = False saveFileName = Replace(Filename, ".xlsx", ".xls") wb.SaveAs Filename:=Pathname & saveFileName, _ FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _ ReadOnlyRecommended:=False, CreateBackup:=False wb.Close SaveChanges:=False Filename = Dir() Loop Application.DisplayAlerts = initialDisplayAlerts End Sub 

Answer 2

 Sub SaveAllAsXLSX() Dim strFilename As String Dim strDocName As String Dim strPath As String Dim wbk As Workbook Dim fDialog As FileDialog Dim intPos As Integer Dim strPassword As String Dim strWritePassword As String Dim varA As String Dim varB As String Dim colFiles As New Collection Dim vFile As Variant Set fDialog = Application.FileDialog(msoFileDialogFolderPicker) With fDialog .Title = "Select folder and click OK" .AllowMultiSelect = True .InitialView = msoFileDialogViewList If .Show <> -1 Then MsgBox "Cancelled By User", , "List Folder Contents" Exit Sub End If strPath = fDialog.SelectedItems.Item(1) If Right(strPath, 1) <> "\" Then strPath = strPath + "\" End With If Left(strPath, 1) = Chr(34) Then strPath = Mid(strPath, 2, Len(strPath) - 2) End If Set obj = CreateObject("Scripting.FileSystemObject") RecursiveDir colFiles, strPath, "*.xls", True For Each vFile In colFiles Debug.Print vFile strFilename = vFile varA = Right(strFilename, 3) If (varA = "xls" Or varA = "XLS") Then Set wbk = Workbooks.Open(Filename:=strFilename) If wbk.HasVBProject Then wbk.SaveAs Filename:=strFilename & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled Else wbk.SaveAs Filename:=strFilename & "x", FileFormat:=xlOpenXMLWorkbook End If wbk.Close SaveChanges:=False obj.DeleteFile (strFilename) End If Next vFile End Sub Public Function RecursiveDir(colFiles As Collection, _ strFolder As String, _ strFileSpec As String, _ bIncludeSubfolders As Boolean) Dim strTemp As String Dim colFolders As New Collection Dim vFolderName As Variant 'Add files in strFolder matching strFileSpec to colFiles strFolder = TrailingSlash(strFolder) strTemp = Dir(strFolder & strFileSpec) Do While strTemp <> vbNullString colFiles.Add strFolder & strTemp strTemp = Dir Loop If bIncludeSubfolders Then 'Fill colFolders with list of subdirectories of strFolder strTemp = Dir(strFolder, vbDirectory) Do While strTemp <> vbNullString If (strTemp <> ".") And (strTemp <> "..") Then If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then colFolders.Add strTemp End If End If strTemp = Dir Loop 'Call RecursiveDir for each subfolder in colFolders For Each vFolderName In colFolders Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True) Next vFolderName End If End Function Public Function TrailingSlash(strFolder As String) As String If Len(strFolder) > 0 Then If Right(strFolder, 1) = "\" Then TrailingSlash = strFolder Else TrailingSlash = strFolder & "\" End If End If End Function