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

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

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\*.*"会报错

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

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

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

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

#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

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