vba Excel宏将xlsx转换为xls

Excel Macro to convert xlsx to xls

提问by user1570210

i have bunch of files in folder all of them are in xlsxformat, I need to convert them to xlsformat. This is going to be done on daily bases.

我在文件夹中有一堆文件，它们都是xlsx格式，我需要将它们转换为xls格式。这将每天进行。

I need a macro which will loop around the folder and convert the file to xls from xlsx with out changing file name.?

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

Here is the macro I am using to loop

这是我用来循环的宏

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

回答by Glenn Stevens

What you are missing is that instead of calling wb.Close SaveChanges=Trueto save the file in another format, you need to call wb.SaveAswith the new file formatand name.

您缺少的是wb.Close SaveChanges=True，您需要wb.SaveAs使用新的文件格式和名称进行调用，而不是调用以另一种格式保存文件。

You said you want to convert them without changing the file name, but I suspect you really meant you want to save them with the same base file name, but with the .xlsextension. So if the workbook is named book1.xlsx, you want to save it as book1.xls. To calculate the new name you can do a simple Replace()on the old name replacing the .xlsxextension with .xls.

你说你想在不更改文件名的情况下转换它们，但我怀疑你真的想用相同的基本文件名保存它们，但使用.xls扩展名。因此，如果工作簿已命名book1.xlsx，您希望将其另存为book1.xls. 要计算新名称，您可以Replace()对旧名称进行简单操作，将.xlsx扩展名替换为.xls.

You can also disable the compatibility checker by setting wb.CheckCompatibility, and suppress alerts and messages by setting Application.DisplayAlerts.

您还可以通过设置禁用兼容性检查器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

回答by pratap

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