VBA 有用的小段代码收藏（日积月累）

2021.3.12

---

1. 启动Excel后只留用户窗体 

Private Sub Workbook_Open()

    Application.Visible = False
    UserForm1.Show vbModeless

End Sub

2. 判断文件（夹）是否存在

Private Function bFileExist(ByVal strFullName As String) As Boolean
    
    If Dir(strFullName, vbDirectory) <> Empty Then
        bFileExist = True
    Else
        bFileExist = False
    End If

End Function

Private Sub CommandButton1_Click()

    Dim sFN As String
    sFN = "D:\abc\*.*"
    MsgBox IIf(bFileExist(sFN), "存在", "不存在")

End Sub

' 可以判断文件或文件夹，支持通配符
' sFN = 判断"D:\abc"，abc可能是文件夹，也可能是一个没有后缀的文件
' 如存在文件abc时判断"D:\abc\*.*"会报错

Dir [ (pathname [ , attributes ] ) ]

pathname    可选参数。用来指定文件名的字符串表达式，可能包含目录或文件夹、以及驱动器。如果没有找到 pathname，则会返回零长度字符串 ("")。
attributes     可选参数。常数或数值表达式，其总和用来指定文件属性。如果省略，则会返回匹配 pathname 但不包含属性的文件。

attributes 参数的设置可为：

常数                值    描述
vbNormal         0    (缺省) 指定没有属性的文件
vbReadOnly    1    指定无属性的只读文件
vbHidden         2    指定无属性的隐藏文件
VbSystem       4    指定无属性的系统文件 在Macintosh中不可用
vbVolume        8    指定卷标文件；如果指定了其它属性，则忽略vbVolume在Macintosh中不可用
vbDirectory   16    指定无属性文件及其路径和文件夹
vbAlias          64    指定的文件名是别名，只在Macintosh上可用。

3. 返回Windows系统文件夹的路径

Function DesktopPath() As String

    Dim wsShell As Object
    Set wsShell = CreateObject("WScript.Shell")
    DesktopPath = wsShell.SpecialFolders("Desktop") & "\"

End Function

Private Sub CommandButton1_Click()

    MsgBox DesktopPath

End Sub

可用的SpecialFolders常量：

桌面： Desktop
公共桌面： AllUsersDesktop 

开始菜单： StartMenu 
公共程式： AllUsersStartMenu 

程序： Programs 
公共程序： AllUsersPrograms 

启动： Startup 
公共启动： AllUsersStartup 

收藏： Favorites 
字体： Fonts 
网络： NetHood 
最近： Recent 
发给： SendTo 
模板： Templates 
打印机： PrintHood 
我的文档： MyDocuments
应用程序数据： AppData 

4. 判断指定名称的Sheet是否存在（遍历所有的Sheet）

Private Function bSheetExist(ByVal strSheetName As String) As Boolean
    
    Dim ws As Worksheet
    Dim bExist As Boolean
    bExist = False
    For Each ws In Worksheets
        If ws.Name = strSheetName Then
            bExist = True
           Exit For
        End If
    Next
    bSheetExist = bExist

End Function

Private Sub CommandButton1_Click()

    MsgBox IIf(bSheetExist("Sheet3"), "存在", "不存在")

End Sub

5. 分拆长字符串到字串数组

Sub splitString()

Dim I As Integer
Dim strTitle As String
Dim arrTitle() As String

strTitle = "报告日期|一级行名称|二级行名称|支行名称|客户编号|客户名称"
arrTitle = VBA.Split(strTitle, "|")

For I = LBound(arrTitle) To UBound(arrTitle)
    Debug.Print arrTitle(I)
Next

Debug.Print "字符串个数：" & UBound(arrTitle) + 1

End Sub

Split ( expression , [ delimiter , [ limit , [ compare ] ] ] )

参数             含义
expression   需要拆分的字符串
delimiter       参数为拆分的分隔符（缺省时用空格分隔）
limit              指定返回字符串的数量
compare      指定拆分子字符串时的比较类型

arrResult = VBA.Split(strString, delimiter:="s", compare:=vbTextCompare)
vbTextCompare 忽略分隔符大小写    vbBinaryCompare 区别分隔符大小写

6. 遍历删除单元格中的网址链接

Sub unLink()

    Dim r As Range
    For Each r In Range("A1:A10")
        r.Hyperlinks.Delete
    Next

End Sub

 7. API函数条件解释、计算时间差

#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If

Private Sub Test()

Dim iTime As Single
iTimer = Timer
Sleep 1000
MsgBox "耗时：" & Timer - iTimer

Dim lTime As Long
lTimer = GetTickCount
Sleep 1000
MsgBox "耗时：" & GetTickCount - lTimer

End Sub

Timer() 返回秒数，值为Single型
GetTickCount() 返回毫秒数，值为Long型

#If VBA7 Then
‘ win64位的代码
#Else
‘ win32位的代码
#End If

PtrSafe 关键字，请参见：
https://docs.microsoft.com/zh-cn/office/vba/language/reference/user-interface-help/ptrsafe-keyword

8. 文件全名分拆成路径和文件名

Private Function strFileName(ByVal strFullName) As String

    Dim I As Integer, tmp As String
    tmp = ""
    For I = Len(strFullName) To 1 Step -1
        If Mid(strFullName, I, 1) = Application.PathSeparator Then
            strFileName = tmp
            Exit Function
        End If
        tmp = Mid(strFullName, I, 1) & tmp
    Next I

    strFileName = tmp

End Function

Private Function strPathName(ByVal strFullName) As String

    Dim I As Integer, tmp As String
    If Right(strFullName, 1) = Application.PathSeparator Then
        strPathName = strFullName
        Exit Function
    End If
    For I = Len(strFullName) To 1 Step -1
        If Mid(strFullName, I, 1) = Application.PathSeparator Then Exit For
    Next I

    strPathName = Left(strFullName, I)

End Function

Sub Test()

Dim fn As String
fn = "c:\abc\abc.txt"
MsgBox strPathName(fn) & " " & strFileName(fn)

End Sub