将xlsx转换为xls的Excel宏

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

- user1570210

Answer 1

你需要注意的是，不要使用wb.Close SaveChanges=True将文件以另一种格式保存，而是需要调用wb.SaveAs并指定新的文件格式和名称来进行保存。

你说你想在不改变文件名的情况下进行转换，但我怀疑你真正想要的是将它们另存为与原始文件名相同，但扩展名为.xls的文件。因此，如果工作簿的名称为book1.xlsx，则你需要将其另存为book1.xls。你可以通过对旧名称执行一个简单的Replace()操作来计算新名称，将.xlsx扩展名替换为.xls。

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

- Glenn Stevens

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

- pratap