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