Excel Vba快速界面设计入门

一、打开 开发工具->Visual Basic ，进入代码编辑区。

二、双击 ThisWorkbook ，从右侧上部选择 打开事件，并输入代码。

Private Sub Workbook_Open()
    Application.Visible = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    UserForm1.Show
End Sub

三、从 插入->用户窗口，会插入界面，左侧会出现UserForm1，根据相关功能插入对应控件并修改属性（同VB)。

四、双击控件，进入对应控件的代码输入。

以选择目录对2003版excel改为2007版本excel为例：

（其中，用的dir递归循环查找，由于涉及递归中混淆dir默认目录，所以递归中的目录必须进入数组，这样才能调用深层递归）

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