Excel宏将xlsx转换为xls

Question

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

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

这里是宏我使用循环

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

你所缺少的是不是调用wb.Close SaveChanges=True将文件保存为另一种格式，您需要调用wb.SaveAs新文件format和名称。

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

您还可以通过设置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