IT技术互动交流平台

Excel VBA将一个目录下的所有xls文件批量转换为xlsx文件

发布日期:2012-09-12 11:37:12
Option Explicit

Sub xlsTOxlsx()
    Dim strFilePath As String, strFileName As String, strFileType As String
    Dim aIndex As Long, arrFileName() As String, strNewName As String

    '设置文件扩展名标识文件类型
    strFileType = ".xls"

    On Error Resume Next
    '设置文件夹路径
    strFilePath = CreateObject("shell.application").BrowseForFolder(0, "请选择文件夹", 0).self.Path
    If Err <> 0 Or InStr(1, strFilePath, "::") > 0 Then
        Err = 0
        Exit Sub
    End If

    '开始搜索文件
    strFileName = Dir(strFilePath & "*.*")
    Do While strFileName <> ""
        If LCase(Right(strFileName, Len(strFileType))) = LCase(strFileType) Then
            ReDim Preserve arrFileName(aIndex)
            arrFileName(aIndex) = strFileName
            aIndex = aIndex + 1
            'Debug.Print strFileName
        End If
        strFileName = Dir
        DoEvents
    Loop
    If aIndex = 0 Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For aIndex = LBound(arrFileName) To UBound(arrFileName)
        strNewName = Mid(arrFileName(aIndex), 1, Len(arrFileName(aIndex)) - Len(strFileType)) & ".xlsx"
        Workbooks.Open strFilePath & arrFileName(aIndex)
        ActiveWorkbook.SaveAs Filename:=strFilePath & strNewName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        Workbooks(strNewName).Close False  '关闭工作簿
        Kill strFilePath & arrFileName(aIndex)
        DoEvents
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "操作完成,共为您转换了 " & UBound(arrFileName) + 1 & " 个文件。", vbOKOnly, "完成"
End Sub

Tag标签: Excel   VBA   xls文件  
  • 专题推荐

About IT165 - 广告服务 - 隐私声明 - 版权申明 - 免责条款 - 网站地图 - 网友投稿 - 联系方式
本站内容来自于互联网,仅供用于网络技术学习,学习中请遵循相关法律法规