VBA Excel 常用 自定义函数
1. 将 互换 Excel 列号（数字/字母）
Public Function excelColumn_numLetter_interchange(numOrLetter) As String
Dim i, j, idx As Integer
Dim letterArray
letterArray = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z")
If IsNumeric(numOrLetter) Then
If numOrLetter > 702 Then
MsgBox "只允许输入小于“703”的数字。"
Exit Function
End If
If numOrLetter > 26 Then
idx = 26
For i = 0 To 25
For j = 0 To 25
idx = idx + 1
If idx = numOrLetter Then
excelColumn_numLetter_interchange = letterArray(i) & letterArray(j)
Exit For
End If
Next j
Next i
Else
excelColumn_numLetter_interchange = letterArray(numOrLetter - 1)
End If
Else
numOrLetter = UCase(numOrLetter) '转换为大写
If Len(numOrLetter) > 1 And Len(numOrLetter) < 3 Then
idx = 26
For i = 0 To 25
For j = 0 To 25
idx = idx + 1
If letterArray(i) & letterArray(j) = numOrLetter Then
excelColumn_numLetter_interchange = idx
Exit For
End If
Next j
Next i
ElseIf Len(numOrLetter) = 1 Then
For i = 0 To 25
If letterArray(i) = numOrLetter Then
excelColumn_numLetter_interchange = i + 1
Exit For
End If
Next i
Else
MsgBox "最多只允许输入2个“字母”。"
End If
End If
End Function
2. '将 字符串中的 html实体 转换成正常字符(可用)
Public Function htmlDecodes(str As String) As String
If str = "" Then
htmlDecodes = ""
Else
str = Replace(str, "<", "<")
str = Replace(str, ">", ">")
str = Replace(str, "&", "&")
str = Replace(str, """, Chr(34))
str = Replace(str, ">", Chr(39))
htmlDecodes = str
End If
End Function
3. '返回指定元素值在数组中的 数字下标
Public Function getArrayEleId(arr, val) As Integer
Dim i As Integer
For i = 0 To UBound(arr)
If val = arr(i) Then
getArrayEleId = i
Exit For
End If
Next i
End Function
4. '打开“自动计算”
Public Sub openAutoCompute()
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.Calculation = xlAutomatic
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
End Sub
5. '关闭“自动计算”
Public Sub closeAutoCompute()
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
End Sub
6. '切换打印机
Public Sub changePrinter()
Application.Dialogs(xlDialogPrinterSetup).Show
ThisWorkbook.Sheets("setting").Range("C8") = Application.ActivePrinter
End Sub
7. '数值型 一维数组 排序（冒泡0→1）
Public Function sortUp_numberArray(arr) As Variant
Dim i, j As Integer
Dim t
For i = 0 To UBound(arr)
For j = i + 1 To UBound(arr)
If CDbl(arr(i)) > CDbl(arr(j)) Then
t = arr(i)
arr(i) = arr(j)
arr(j) = t
End If
Next j
Next i
sortUp_numberArray = arr
End Function
8. '数值型 二维数组 排序（冒泡0→1）**未验证**
Public Function sortUp_array2d(arr, keyIdxArray) As Variant
Dim h, i, j As Integer
Dim t
For h = 0 To UBound(keyIdxArray)
For i = 0 To UBound(arr)
For j = i + 1 To UBound(arr)
If CDbl(arr(i, keyIdxArray(h))) > CDbl(arr(j, keyIdxArray(h))) Then
t = arr(i)
arr(i) = arr(j)
arr(j) = t
End If
Next j
Next i
Next h
sortUp_array2d = arr
End Function
9. '删除 一维数组中的 重复值
Function del_arraySameValue(arr As Variant) As Variant
Dim i, j As Long
Dim arr2()
Dim is_same As Boolean
ReDim Preserve arr2(0)
arr2(0) = arr(0)
For i = 1 To UBound(arr)
is_same = False
For j = 0 To UBound(arr2)
If arr2(j) = arr(i) Then
is_same = True
Exit For
End If
Next j
If is_same = False Then
ReDim Preserve arr2(UBound(arr2) + 1)
arr2(UBound(arr2)) = arr(i)
End If
Next i
del_arraySameValue = arr2
End Function
10. '检测 一维数组中 是否包含 某值（仅 Double 类型）(不稳定……原因不明)
Function is_inArray(arr As Variant, ele As Double) As Boolean
Dim i As Long
Dim eles As String
On Error Resume Next
eles = Join(arr, ",")
i = Application.WorksheetFunction.Match(ele, arr, 0)
If Err = 0 Then
is_inArray = True
Exit Function
End If
is_inArray = False
End Function
11. '检测 一维数组中 是否包含 某值
Function is_inArray3(arr, ele) As Boolean
Dim arr1
Dim arr_str As String
is_inArray = False
arr1 = VBA.Filter(arr, ele, True) '筛选所有含 ele 的数值组成一个新数组
arr_str = Join(arr1, ",")
If Len(arr_str) > 0 Then
is_inArray = True
End If
' If Not is_emptyArray(arr1) Then
' is_inArray = True
' End If
End Function
12. '检测 二维数组中 是否包含 某值
Function is_in2dArray(arr() As Variant, ele) As Boolean
If WorksheetFunction.CountIf(Application.Index(arr, 1, 0), ele) > 0 Then
is_inArray = True
Else
is_inArray = False
End If
End Function
13. '判断是否为 “空数组”
'需 api 引用：Public Declare Function SafeArrayGetDim Lib "oleaut32.dll" (ByRef saArray() As Any) As Long
Function is_emptyArray(ByRef X() As String) As Boolean
Dim tempStr As String
tempStr = Join(X, ",")
is_emptyArray = LenB(tempStr) <= 0
End Function
14. 日期处理 函数
'将时间戳（10或13位整数）转换成 yyyy-mm-dd hh:mm:ss 格式的日期
Public Function timeStamp2date(timeStamp As Double, Optional beginDate = "01/01/1970 08:00:00")
If Len(CStr(timeStamp)) = 13 Then timeStamp = timeStamp / 1000
timeStamp2date = DateAdd("s", timeStamp, beginDate)
End Function
'将 yyyy-mm-dd hh:mm:ss 转换成 时间戳（10位整数）
Public Function date2timeStamp(theDate As Date, Optional timeDiff = 28800)
date2timeStamp = DateDiff("s", "01/01/1970 00:00:00", theDate) - timeDiff
End Function
'获取 yyyy-mm-dd hh:mm:ss 中的 yyyy-mm-dd
Public Function getDate(theDate As Date)
getDate = year(theDate) & "-" & month(theDate) & "-" & day(theDate)
End Function
