Private Sub btnBrowser_Click()
    Dim fd As FileDialog
    Dim strPath As String
    
    Set fd = Application.FileDialog(msoFileDialogFolderPicker)
    
    If fd.Show = -1 Then '选择了文件夹
        strPath = fd.SelectedItems(1)
    Else
        strPath = ""
    End If
    
    txtPath.Text = strPath
    Set fd = Nothing
End Sub

Private Sub btnSearch_Click()
    If txtPath.Text = "" Then
        MsgBox ("请选择文件夹后操作！！！")
        Exit Sub
    End If
    Dim strPath As String
    
    If Right(txtPath.Text, 1) <> "\" Then '盘符文件夹时多了一个\,统一规格
        strPath = txtPath.Text & "\"
    End If
    
    SearchFile (strPath)
    lblState.Caption = "查找完成！！！"
End Sub

Private Sub SearchFile(strPath As String)
    Dim strFile As String, strFolder As String, n As Long, i As Long
    Dim strHead As String, strEnd As String, a() As String
    
    strFile = Dir(strPath)
    Do While strFile <> ""
        lblState.Caption = strPath & strFile
        strEnd = Right(strFile, Len(strFile) - InStrRev(strFile, ".")) '尾部，后缀名
        If strEnd = "xls" Then
            strHead = Left(strFile, InStrRev(strFile, ".") - 1) '头部
            
            Set objFS = CreateObject("Scripting.FileSystemObject")  '文件系统检查
            If objFS.fileExists(strPath & strHead & ".xlsx") = False Then '不存在，转换
                Dim wb As Workbook
                Set wb = Application.Workbooks.Open(strPath & strFile)
                wb.SaveAs (strPath & strHead & ".xlsx")
                wb.Close
                Set wb = Nothing
                Kill strPath & strHead & ".xls"
            Else '有了，两文件同时存在
                lstFile.AddItem strPath & strFile
            End If
        End If
        strFile = Dir '继续向下查找
        DoEvents
    Loop
    
    strFolder = Dir(strPath, vbDirectory)
    Do While strFolder <> ""
        If strFolder <> "." And strFolder <> ".." Then
            If GetAttr(strPath & strFolder) And vbDirectory Then
                n = n + 1
                ReDim Preserve a(n)
                a(n) = strPath & strFolder & "\"
                lblState.Caption = strPath & strFolder & "\"
            End If
        End If
        strFolder = Dir
        DoEvents
    Loop
    
    For i = 1 To n
        SearchFile (a(i))
    Next i
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Application.Visible = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Dim wb As Workbook, flag As Boolean
    
    flag = False '假定无其它工作薄
    For Each wb In Application.Workbooks
        If wb.Name <> ThisWorkbook.Name Then
            flag = True '有其它工作薄
        End If
    Next
    If flag = False Then '仅本工作蔳，直接退出excel
        'Application.Quit
    End If
End Sub