一些有意思的自定义函数（部分抄录）

2023-12-18更新

对参数中黄色底纹的单元格进行求和

Function CountByYellow(rng  As Range)  As Long
Dim rngCell  As Range
Dim lngCnt  As Long
Application.Volatile
lngCnt = 0
If Not rng  Is Nothing Then
    For Each rngCell  In rng
        With rngCell
            If .Interior.ColorIndex = 6  Then
                lngCnt = lngCnt + .Value
            End If
        End With
    Next
End If
CountByYellow = lngCnt
End Function

由第二参数指定颜色单元格的求和 

Function SumByColor(rng As Range, Color As Long) As Long
Dim rngCell  As Range
Dim lngCnt  As Long
Application.Volatile
lngCnt = 0
If Not rng Is Nothing Then
    For Each rngCell In rng
        With rngCell
            If .Interior.ColorIndex = Color Then
                lngCnt = lngCnt + .Value
            End If
        End With
    Next
End If
SumByColor = lngCnt
End Function

　

模拟Concat函数

Function ConcatText(arr)
Dim MyStr As String
Dim MyCell As Range
MyStr =  ""
For Each MyCell  In arr
    MyStr = MyStr & MyCell
Next
ConcatText = MyStr
End Function

模拟TextJoin函数（无是否忽略空单元格的功能 ）

Function ConcatText(delimiter As String, arr)
Dim MyStr As String
Dim MyCell As Range
MyStr = ""
For Each MyCell In arr
    MyStr = MyStr & delimiter & MyCell
Next
ConcatText = Mid(MyStr, Len(delimiter) + 1, 99)
End Function

提取字符串中的数字

Function GetNumber(pStr As String)
Dim i As Long
Dim MyStr As String
For i = 1 To Len(pStr)
    MyStr = Mid(pStr, i, 1)
    If MyStr Like "[0-9]" Then
        GetNumber = GetNumber & MyStr
    End If
Next
End Function

　　

提取字符串中的字母

Function GetLetter(pStr As String)
Dim i As Long
Dim MyStr As String
For i = 1 To Len(pStr)
    MyStr = Mid(pStr, i, 1)
    If MyStr Like "[a-z,A-Z]" Then
        GetLetter = GetLetter & MyStr
    End If
Next
End Function

提取字符串中的汉字

Function GetCharacter(pStr As String)
Dim i As Long
Dim MyStr As String
For i = 1 To Len(pStr)
    MyStr = Mid(pStr, i, 1)
    If MyStr Like "[一-龥]" Then
        GetCharacter = GetCharacter & MyStr
    End If
Next
End Function

提取由第二参数指定种类的字符

Function GetCharacter(pStr As String, pType As Variant)
Dim i As Long
Dim MyStr As String, MyType As String
If pType = "number" Or pType = 1 Then
    MyType = "[0-9]"
ElseIf pType = "letter" Or pType = 2 Then
    MyType = "[a-z,A-Z]"
ElseIf pType = "character" Or pType = 3 Then
    MyType = "[一-龥]"
End If
For i = 1 To Len(pStr)
    MyStr = Mid(pStr, i, 1)
    If MyStr Like MyType Then
        GetCharacter = GetCharacter & MyStr
    End If
Next
End Function

按指定字符数拆分 

Function SplitbyN(fText As String, fNumber As Long)
Dim i As Long
Dim MyArr
ReDim MyArr(1 To Application.RoundUp(Len(fText) / fNumber, 0))
For i = 1 To Len(fText) Step fNumber
    MyArr(Int((i + fNumber - 1) / fNumber)) = Mid(fText, i, fNumber)
Next
SplitbyN = MyArr
End Function

按分隔符拆分（单纯横向拆分）

Function SplitByC(fText As String, fDelimiter As String)
SplitByC = Split(fText, fDelimiter)
End Function

　　

四舍六入五成双

Function pRound(Number, Digits)
  pRound = Round(CDec(Number), Digits)
End Function