在不打开工作簿的情况下，使用VBA将.xls批量转换为.xlsx

Question

我有一堆旧.xls格式的Excel工作簿。我想使用VBA将它们转换为.xlsx。以下代码完成了此任务，但需要打开每个工作簿才能再次保存。

Dim wbk As Workbook
Set wbk = Workbooks.Open(filename:="C:someexamplepathworkbook.xls")
wbk.SaveAs filename:="C:someexamplepathworkbook.xlsx", _
FileFormat:=xlOpenXMLWorkbook, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
wbk.Close SaveChanges:=False

有没有其他方法可以在不需要打开每个工作簿的情况下完成此任务？这对于至少30-100本工作簿来说是非常耗时的。

Answer 1

下面是一段代码，用于获取您想要的内容：

Sub ChangeFileFormat()
    Dim strCurrentFileExt   As String
    Dim strNewFileExt       As String
    Dim objFSO              As Object
    Dim objFolder           As Object
    Dim objFile             As Object
    Dim xlFile              As Workbook
    Dim strNewName          As String
    Dim strFolderPath       As String
    strCurrentFileExt = ".xls"
    strNewFileExt = ".xlsx"
    strFolderPath = "C:UsersScorpioDesktopNew folder"
    If Right(strFolderPath, 1) <> "" Then
        strFolderPath = strFolderPath & ""
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.getfolder(strFolderPath)
    For Each objFile In objFolder.Files
        strNewName = objFile.Name
        If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then
            Set xlFile = Workbooks.Open(objFile.Path, , True)
            strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt)
            Application.DisplayAlerts = False
            Select Case strNewFileExt
            Case ".xlsx"
                xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook
            Case ".xlsm"
                xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled
            End Select
            xlFile.Close
            Application.DisplayAlerts = True
        End If
    Next objFile
ClearMemory:
    strCurrentFileExt = vbNullString
    strNewFileExt = vbNullString
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
    Set xlFile = Nothing
    strNewName = vbNullString
    strFolderPath = vbNullString
End Sub

这是XL文件格式的链接：https://msdn.microsoft.com/en-us/library/office/ff198017.aspx

---------------------------------------------

一位修改：检查这个代码，我只更改了它的扩展名，但请检查它的兼容性。。。让我知道它对你有用吗。。。

Sub ChangeFileFormat_V1()
    Dim strCurrentFileExt   As String
    Dim strNewFileExt       As String
    Dim objFSO              As Object
    Dim objFolder           As Object
    Dim objFile             As File  'Object
    Dim xlFile              As Workbook
    Dim strNewName          As String
    Dim strFolderPath       As String
    strCurrentFileExt = ".xls"
    strNewFileExt = ".xlsx"
    strFolderPath = "C:UsersScorpioDesktopNew folder"
    If Right(strFolderPath, 1) <> "" Then
        strFolderPath = strFolderPath & ""
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.getfolder(strFolderPath)
    For Each objFile In objFolder.Files
        strNewName = objFile.Name
        If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then
            strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt)
            Application.DisplayAlerts = False
            objFile.Name = strNewName
            Application.DisplayAlerts = True
        End If
    Next objFile
ClearMemory:
    strCurrentFileExt = vbNullString
    strNewFileExt = vbNullString
    Set objFSO = Nothing
    Set objFolder = Nothing
    Set objFile = Nothing
    Set xlFile = Nothing
    strNewName = vbNullString
    strFolderPath = vbNullString
End Sub