【原】VBA【代码】我常用的自定义函数代码集合

内容提要

• 常用代码合集

1、wContinue确认继续函数，函数的返回值为TRUE或False，通常用于在执行一个过程时，提请用户确认，防止误操作，避免出现“灾难性“的后果，比如在清空数据库前要反复确认，或者是一个比较耗时的操作，在执行前进行确认：

Function wContinue(Msg As String) As Boolean    ' 确认继续函数    Dim Config As VbMsgBoxStyle    Dim ans As VbMsgBoxResult    Config = vbYesNo + vbQuestion + vbDefaultButton2    ans = MsgBox(Msg & Chr(10) & Chr(10) & "是(Y)继续?" & Chr(10) & Chr(10) & "否(N)退出！", Config)    wContinue = (ans = vbYes)End Function

2、fileSelected函数，取得选择的文件完整路径，通常用于由用户选择执行操作的文件：

Function fileSelected()    With Application.FileDialog(msoFileDialogFilePicker)        If .Show = -1 Then            fileSelected = .SelectedItems(1)        Else            Exit Function        End If    End WithEnd Function

3、FolderSelected，获取用户选择的文件夹路径：

Function FolderSelected(Optional title As String = "请选择文件夹......")    With Application.FileDialog(msoFileDialogFolderPicker)        .title = title        .InitialFileName = ThisWorkbook.Path        If .Show = -1 Then            FolderSelected = .SelectedItems(1)        Else            Exit Function        End If    End WithEnd Function

4、IsArrEmpty，判断数组是否为空，常用于获取SQL语句查询结果，存到一个数组里的情况，如果没有查到记录，则数组为空，后续对数组的操作就会报错，通过这个函数先判断一下，如果为空则退出过程或者跳过接下来操作数组的代码：

Function IsArrEmpty(ByVal arr As Variant) As Boolean    '//判断数组是否为空    Dim i As Long    IsArrEmpty = False    On Error GoTo Er    i = UBound(arr)    Exit FunctionEr:    IsArrEmpty = TrueEnd Function

5、Pxy函数，数组字段定位，返回一个整数，相当工作表函数Match，常用于操作一个字段非常多的表格，我们把它读到数组里，用Pxy函数，取得某字段对应的行号或列标，省得去一行一列地数字段的位置，并且还有一个好处，就是表格字段位置变化时，有可能不需要修改代码：

Function Pxy(arr(), FieldName As String, Optional arrType As Integer = 0)    '**********************************    '//参数说明：    '//arr(),数组，可以是一维也可以是二维    '//FieldName，字段名，需要定位的字段名    '//arrType=0,表示一维数组    '//arrType=1,表示二维数组，查找第一列    '//arrType=2,表示二维数组，查找第一行    '**********************************    k = 0: t = 0    Select Case arrType    Case Is = 0        For i = LBound(arr) To UBound(arr)            k = k + 1            If arr(i) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 1        For i = LBound(arr, 1) To UBound(arr, 1)            k = k + 1            If arr(i, 1) = FieldName Then                t = 1                Exit For            End If        Next    Case Is = 2        For i = LBound(arr, 2) To UBound(arr, 2)            k = k + 1            If arr(1, i) = FieldName Then                t = 1                Exit For            End If        Next    End Select    If t = 1 Then        Pxy = k    Else        Pxy = 0    End IfEnd Function

6、GetExtn函数，取得文件扩展名，常用于操作某一类型的文件时：

Function GetExtn(iName)    '//取得文件扩展名    GetExtn = Right(iName, Len(iName) - InStrRev(iName, ".") + 1)End Function
Function GetExtn(fileName)    '//取得文件扩展名,小写，不包含"."    GetExtn = LCase(Right(fileName, Len(fileName) - InStrRev(fileName, ".")))End Function

7、连接数据库（Access、Excel文件）相关自定义函数、过程，这几个函数要结合使用，有互相调用。可以放到一个标准模块，也可以放到一个类模块：

（1）GetStrCnn函数，取得连接数据库的连接字符串

（2）ExecuteSQL过程，执行SQL语句，通常用于Update、Delete语句

（3）RecordValue函数，通过执行一个count查询语句，返回一个0或者是大于0的数字，0表示没有符合条件的记录，大于0表示有记录，通常用于判断一个表是否有记录，或者是否有符合条件的记录

（4）getData函数，返回的是一个SQL查询结果，存到数组

Dim strCnn As StringDim cnn As ObjectDim rs As ObjectFunction GetStrCnn(ByVal DbFile As String, Optional ByVal Psw As String = "")    '//获取数据库连接字符串    Dim sType$    sType = GetExtn(DbFile)    If InStr(sType, "accdb") Then        Select Case Application.Version * 1      '设置连接字符串,根据版本创建连接        Case Is <= 11            GetStrCnn = "Provider=Microsoft.Jet.Oledb.4.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile        Case Is >= 12            GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Jet OLEDB:Database Password=" & Psw & ";Data Source=" & DbFile        End Select    ElseIf InStr(sType, "xl") Then        GetStrCnn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & DbFile    End IfEnd Function
Sub ExecuteSQL(sql As String)    '//执行SQL语句    On Error Resume Next    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    dbs = ThisWorkbook.FullName    strCnn = GetStrCnn(dbs, Psw)    cnn.Open strCnn    '打开数据库链接    cnn.Execute (sql)    cnn.Close    Set cnn = NothingEnd Sub
Function RecordValue(sql)    '函数名的含义为“记录值”，实际为取到的第一行第一列的值    '通常用来 select count() 来取值，这样，函数的值或为0,或大于0,如果值为0,则表示没有记录    '可以用来判断一个表有没有记录，或者有没有指定字段符合一定条件的记录    On Error Resume Next    Dim arr()    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    On Error Resume Next    dbs = ThisWorkbook.FullName    strCnn = GetStrCnn(dbs, Psw)    cnn.Open strCnn    Set rs = cnn.Execute(sql)    arr = rs.getrows    RecordValue = arr(0, 0)    rs.Close    Set rs = Nothing    cnn.Close    Set cnn = NothingEnd Function
Function getData(sql)    '//获取查询结果，存到数组'    On Error Resume Next    Set cnn = CreateObject("ADODB.Connection")    Set rs = CreateObject("ADODB.Recordset")    On Error Resume Next    dbs = ThisWorkbook.FullName    strCnn = GetStrCnn(dbs, Psw)    cnn.Open strCnn    Set rs = cnn.Execute(sql)    getData = rs.getrows    rs.Close    Set rs = Nothing    cnn.Close    Set cnn = NothingEnd Function

8、数字转中文金额大写，还有别的版本，这个是我自己写的

Function NumToChar(Number As Double) As String    Dim strNum As String    Dim arrNum(), arrChar(), arrUnits(), arr()    Dim k As Integer    Temp = Abs(Round(Number, 2)) * 100    strNum = CStr(Temp)    arrChar = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")    arrUnits = Array("分", "角", "元", "拾", "佰", "仟", "万", "拾", "佰", "仟", "亿", "拾", "佰", "仟", "兆", "拾", "佰", "仟", "京")    For i = Len(strNum) To 1 Step -1        ReDim Preserve arr(k)        arr(k) = Mid(strNum, i, 1)        If arr(k) = 0 Then            If InStr("元万亿兆", arrUnits(k)) Then                arr(k) = arrUnits(k)            Else                arr(k) = "零"            End If        Else            arr(k) = arrChar(arr(k)) & arrUnits(k)        End If        k = k + 1    Next    strNum = ""    For i = UBound(arr) To LBound(arr) Step -1        strNum = strNum & arr(i)    Next    If Round(Number, 0) = Number Then        strNum = Left(strNum, InStr(strNum, "元")) & "整"    ElseIf Round(Number, 1) = Number Then        strNum = Left(strNum, InStr(strNum, "角")) & "整"    End If    Do While InStr(strNum, "零零") > 0       strNum = Replace(strNum, "零零", "零")    Loop    strNum = Replace(strNum, "零兆", "兆")    strNum = Replace(strNum, "零亿", "亿")    strNum = Replace(strNum, "零万", "万")    strNum = Replace(strNum, "零元", "元")    strNum = Replace(strNum, "兆亿", "兆")    strNum = Replace(strNum, "兆万", "兆")    strNum = Replace(strNum, "亿万", "亿")    If Number < 0 Then        strNum = "负" & strNum    ElseIf Number = 0 Then        strNum = "零元整"    End If    NumToChar = strNumEnd Function

9、SetDataValidation过程，设置单元格数据验证，列表是一个数组， 这里是二维数组，如果是一维数组代码需要稍微修改一下：

Sub SetDataValidation(arr(), rng As Range)    '//设置单元格数据验证    Dim listStr As String    For i = LBound(arr) To UBound(arr, 2)        listStr = listStr & arr(0, i) & ","    Next    '//去掉结尾的 ","    listStr = Left(listStr, Len(listStr) - 1)    '//删除已有的数据验证    rng.Validation.Delete    With rng.Validation        '//添加数据验证，源为listStr        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _            Operator:=xlBetween, Formula1:=listStr        .IgnoreBlank = True        .InCellDropdown = True        .ShowInput = True        .ShowError = False  '//不显示出错警告，改为TRUE则显示，同时不能输入不合验证的字符    End WithEnd Sub

以上就是我常用的自定义函数，基本上可以直接拿来就用。其他个性化的过程、函数就不再一一列举了，基本上都在公众号案例文章里。

在整理这些代码的过程中，我发现不少函数、过程的返回值数据类型没有定义，返回值是数组的，我们可以不定义，要定义也是Variant类型，其他返回值是字符串、数值的，应该要定义一下。