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