VBAExcel常⽤⾃定义函数
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
vba排序函数sort用法  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

版权声明：本站内容均来自互联网，仅供演示用，请勿用于商业和其他非法用途。如果侵犯了您的权益请与我们联系QQ:729038198，我们将在24小时内删除。