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, "&lt;", "<")
　　　　str = Replace(str, "&gt;", ">")
　　　　str = Replace(str, "&amp;", "&")
　　　　str = Replace(str, "&quot;", Chr(34))
　　　　str = Replace(str, "&gt;", 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