VBA Excel 常用 自定义函数

时间:2021-08-29 12:59:36

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