VBA 批量转换xls文件

最新推荐文章于 2024-09-26 16:07:24 发布

chunyu.wu

最新推荐文章于 2024-09-26 16:07:24 发布

阅读量330

点赞数 2

分类专栏： VBA 文章标签： VBA

本文链接：https://blog.csdn.net/wuchunyu002/article/details/140295609

版权

VBA 专栏收录该内容

64 篇文章 3 订阅

订阅专栏

将.xls格式的Excel文件批量转换成.xlsx或.xlsm（没有宏时转换成.xlsx,有宏时转换成.xlsm）

Option Explicit

Sub BatchConvertXLSFiles()
    Dim wb As Workbook
    Dim strSelectedPath As String
    Dim strFileFullPath As String
    Dim strFile As String
    
On Error GoTo ErrProcess

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = ThisWorkbook.Path & "\"
        .Title = "Select Path"
        If .Show Then
            strSelectedPath = .SelectedItems(1)
            strFileFullPath = Dir(strSelectedPath & "\*.xls")
            Do While strFileFullPath <> ""
                If Right(strFileFullPath, 3) = "xls" Then
                    strFile = Left(strFileFullPath, InStrRev(strFileFullPath, ".") - 1)
                    Set wb = Application.Workbooks.Open(strSelectedPath & "\" & strFileFullPath, 0)
                    If wb.HasVBProject Then
                        wb.SaveAs Filename:=strSelectedPath & "\" & strFile, FileFormat:=xlOpenXMLWorkbookMacroEnabled
                    Else
                        wb.SaveAs Filename:=strSelectedPath & "\" & strFile, FileFormat:=xlOpenXMLWorkbook
                    End If
                    wb.Close SaveChanges:=False
                End If
                strFileFullPath = Dir()
            Loop
            Set wb = Nothing
        Else
            MsgBox prompt:="Path selection is canceled.", Title:="Select Path"
            Exit Sub
        End If
    End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Done."
    Exit Sub
ErrProcess:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox Err.Description
End Sub