VBA Excel 常用 自定义函数【二】
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
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
15. 查找指定文件夹含子文件夹内所有文件名或文件夹名
'*******************************************************************************************************
'功能： 查找指定文件夹含子文件夹内所有文件名或文件夹名（含路径）
'函数名： FileAllArr
'参数1： Filename 需查找的文件夹名，不包含文件名
'参数2： FileFilter 需要过滤的文件名，可省略，默认为：[*.*]
'参数3： Liwai 剔除例外的文件名，可省略，默认为：空，一般为：ThisWorkbook.Name
'参数4： SubFiles 是否需要查找子文件夹内文件，可省略，默认为：true
'参数5： Files 是否只要文件夹名，可省略，默认为：FALSE
'返回值： 一个字符型的数组
'使用方法：FileArr = FileAllArr(ThisWorkbook.Path, '*.xls', ThisWorkbook.Name,false,false)
'作者: 北极狐工作室
'*******************************************************************************************************
Public Function FileAllArr(ByVal Filename As String, Optional ByVal FileFilter As String = '*.*', Optional ByVal Liwai As String = '', Optional ByVal SubFiles As Boolean = True, Optional ByVal Files As Boolean = False) As String()
Dim DIC, Ke, MyName, MyFileName
Dim i As Long
Set DIC = CreateObject('Scripting.Dictionary') '创建一个字典对象，保存文件夹路径
Filename = Replace(Replace(Filename & '\', '\\', '\'), '\\', '\') '//如果没有，文件夹名后面补上：\
DIC.Add (Filename), ''
i = 0
Do While i < DIC.Count
Ke = DIC.keys '开始遍历字典
If SubFiles = True Then '//如果需要查找子文件夹
MyName = Dir(Ke(i), vbDirectory) '查找目录
Do While MyName <> ''
If MyName <> '.' And MyName <> '..' Then
If (GetAttr(Ke(i) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录
DIC.Add (Ke(i) & MyName & '\'), '' '就往字典中添加这个次级目录名作为一个条目
End If
End If
MyName = Dir '继续遍历寻找
Loop
End If
i = i + 1
Loop
Dim Arrx() As String '//定义一个数组，用于输出
i = 0
ReDim Preserve Arrx(i)
Arrx(0) = '' '//初始化，避免出错，没有就是：空白
If Files = True Then '//是否只输出文件夹名
For Each Ke In DIC.keys '以查找总表所在文件夹下所有excel文件为例
ReDim Preserve Arrx(i)
If Ke <> Filename Then '//自身文件夹除外
Arrx(i) = Ke
i = i + 1
End If
Next
FileAllArr = Arrx
Else
For Each Ke In DIC.keys '以查找总表所在文件夹下所有excel文件为例
MyFileName = Dir(Ke & FileFilter) '过滤器：EXCEL2003为：*.xls,excel2007为：*.xlsx
Do While MyFileName <> ''
If MyFileName <> Liwai Then '排除例外文件
ReDim Preserve Arrx(i)
Arrx(i) = Ke & MyFileName
i = i + 1
End If
MyFileName = Dir
Loop
Next
FileAllArr = Arrx
End If
End Function
'****************************************************************
16. 对上面的函数提取文件名
Public Function GetPathFromFileName(ByVal strFullPath As String, Optional ByVal kzm As Boolean = False, Optional ByVal strSplitor As String = '\') As String
Dim FileName1 As String
Dim FNAME As String
FileName1 = Left$(strFullPath, InStrRev(strFullPath, strSplitor, , vbTextCompare))
FileName1 = Replace(strFullPath, FileName1, '')
If kzm = False Then
GetPathFromFileName = Left(FileName1, InStrRev(FileName1, '.') - 1)
Else
GetPathFromFileName = FileName1
End If
End Function