共享一组实用的自定义函数

doitbest

10、名称相似度比对函数。
规范名称与不规范名称比对，这是一些部门数据处理的难点。由于实际情况千差万别，计算机很难完美解决这种问题（人脑更强大灵活，但也不能百分百解决问题）。该函数只能明显提高比对效率，但不能达到完全准确，也需要辅以不同程度的手工处理。用户可根据数据的具体情况，对比对函数代码进行个性化的丰富完善。
Public Function 相似度比对(arr, brr, 相似比例)
Rem 主要用于不规范的企业名称模糊比对
Dim crr(), i, ii, reg, dic, times, str, str1
Set dic = CreateObject("Scripting.Dictionary")
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
ReDim crr(1 To UBound(arr), 1 To 2)
For i = 1 To UBound(brr) '目标数组读入字典，为比对做准备
    dic(brr(i, 1)) = ""
Next
For i = 1 To UBound(arr)
    If dic.exists(arr(i, 1)) Then '相同比对
        crr(i, 1) = arr(i, 1)
        crr(i, 2) = "相同"
    Else '相似度比对
        reg.Pattern = "[" & arr(i, 1) & "]"
        For ii = 1 To UBound(brr)
            times = reg.Execute(brr(ii, 1)).count
            If times / Len(arr(i, 1)) >= 相似比例 Then
                str = str & IIf(str = "", "", Chr(10)) & brr(ii, 1)
                str1 = str1 & " " & Round(times / Len(arr(i, 1)) * 100, 1) & "%"
            End If
        Next
        If str <> "" Then crr(i, 1) = str: crr(i, 2) = "'" & Trim(str1)
        str = ""
        str1 = ""
    End If
Next
相似度比对 = crr
Set dic = Nothing
End Function

doitbest

11、显示数组/字典内容函数
此函数方便随时显示数组或字典的内容，可在程序最后显示数组数据，可在程序执行过程中及程序调试时显示数组数据，使数组内容感性化，提高代码调试效率。
Public Function 显示数组(arr, flag, ParamArray Other())
Rem 显示数组连续行或非连续行内容，显示字典键和值的内容
Rem 参数1为数组或字典名称，参数2（1为显示连续区域，后面有起止两个参数；2为显示不连续行，后面参数不确定），参数2后面至少要有两个参数。字典名称后也要有两个参数
Dim brr(), str, r, c, i, max, k, it, max1, max2
If TypeName(arr) = "Dictionary" Then
    ReDim brr(1 To 2)
    k = arr.keys: it = arr.items
    For i = 0 To UBound(k)
        brr(1) = Application.max(Len(k(i)), max1)
        brr(2) = Application.max(Len(k(i)), max2)
    Next
    For i = 0 To UBound(k)
        str = str & i + 1 & Chr(9) & k(i) & Space(brr(1) - Len(k(i))) & Chr(9) & it(i) & Space(brr(2) - Len(it(i)))
        str = str & Chr(10)
    Next
Else
    ReDim brr(1 To UBound(arr, 2))
    For c = 1 To UBound(arr, 2)
        For r = 1 To UBound(arr)
            max = Application.max(Len(arr(r, c)), max)
        Next
        brr(c) = max: max = 0
    Next
    If flag = 1 Then
        For r = Other(0) To Other(1)
            For c = 1 To UBound(arr, 2)
                str = str & IIf(c = 1, r & Chr(9), Chr(9)) & arr(r, c) & Space(brr(c) - Len(arr(r, c)))
            Next
            str = str & Chr(10)
        Next
    Else
        For r = 0 To UBound(Other)
            For c = 1 To UBound(arr, 2)
                str = str & IIf(c = 1, Other(r) & Chr(9), Chr(9)) & arr(Other(r), c) & Space(brr(c) - Len(arr(Other(r), c)))
            Next
            str = str & Chr(10)
        Next
    End If
End If
显示数组 = str
End Function

香川群子

doitbest 发表于 2016-1-9 11:56
2、数组排序函数
VBA没有为我们提供数组排序功能，这是一个缺憾。实际开发中，人们或者书写冗长的排序语句 ...

VBA内数组的多key稳定排序算法，目前是我的算法最完整，最优。（借鉴由于大侠Zamyi）

http://club.excelhome.net/thread-1245495-1-1.html

你的代码只能用来学习，并非值得推荐的排序算法。呵呵。

香川群子

doitbest 发表于 2016-1-9 12:02
5、数组重排列函数
数组重排列函数在应用中比较普遍，存在多行多列数组与多行多列、一行多列、一列多行数 ...

数组处理？

请看这里：
兼具Index、Redim、Transpose多功能的数组处理自定义函数
http://club.excelhome.net/thread-1136072-1-1.html

香川群子

doitbest 发表于 2016-1-9 12:09
6、数组随机排列函数
Public Function sortarrbyrnd(arr)
Rem 数组随机排序函数

又是冒泡排序？！！！

数组随机乱序，只有【洗牌算法】是唯一高效的。其余的都是垃圾。

我给你一个。

1. Sub GetRndArr(arr, a, b, n, Optional k = 0)
   
2.     'arr为一维或二维数组 从范围[a,b]中任取n个不同的随机值 k为一维、按行、按列选项 默认一维
   
3.     Randomize '随机种子初始化 以保证每次得到不同的随机序列
   
4.     If k < 0 Then l = LBound(arr, 2) Else l = LBound(arr) '取得最小下标
   
5.     For i = l To n + l - 1 '按所需提取数n进行
   
6.         r = Int(Rnd() * (b - a + 1 - (i - l))) + a + (i - l) '计算剩余数中的随机位置r
   
7.         If k = 0 Then
   
8.             t = arr(r): arr(r) = arr(i + a - l): arr(i) = t '一维数组洗牌
   
9.         ElseIf k = 1 Then
   
10.             For j = LBound(arr, 2) To UBound(arr, 2)
    
11.                 t = arr(r, j): arr(r, j) = arr(i + a - l, j): arr(i, j) = t '二维数组按行洗牌 整行交换
    
12.             Next
    
13.         ElseIf k = -1 Then
    
14.             For j = LBound(arr) To UBound(arr)
    
15.                 t = arr(j, r): arr(j, r) = arr(j, i + a - l): arr(j, i) = t '二维数组按列洗牌 整列交换
    
16.             Next
    
17.         End If
    
18.     Next
    
19. End Sub

复制代码

香川群子

doitbest 发表于 2016-1-9 12:09
6、数组随机排列函数
Public Function sortarrbyrnd(arr)
Rem 数组随机排序函数

如果是一维数组随机乱序，代码更加简单：

1. Sub GetRnd(arr, a, b, n) '一维数组arr、取值起始a、结束b、提取个数n
   
2.     Randomize
   
3.     l = LBound(arr)
   
4.     For i = l To n + l - 1
   
5.         r = Int(Rnd * (b - a + 1 - (i - l))) + a + (i - l)
   
6.         t = arr(r): arr(r) = arr(a + (i - l)): arr(i) = t
   
7.     Next
   
8. End Sub

复制代码

如果默认全部随机乱序，更简单：

1. Sub GetRnd(arr)
   
2.     Randomize
   
3.     l = LBound(arr): u = UBound(arr)
   
4.     For i = l To u - 1 '可以少循环一次
   
5.         r = Int(Rnd * (u - i + 1)) + i
   
6.         t = arr(r): arr(r) = arr(i): arr(i) = t
   
7.     Next
   
8. End Sub

复制代码

香川群子

doitbest 发表于 2016-1-9 12:11
8、排名函数
如同许多工作表函数一样，RANK函数也不支持数组，更不可能实现中国式排名，给应用者带来遗憾 ...

每次只处理一个值？

中西排名自定义函数
http://club.excelhome.net/thread-1143428-1-1.html
(出处: ExcelHome技术论坛)

bajifeng

感谢doitbest兄共享如此多的自定义函数，
有很多地方值得借鉴学习
谢谢分享，
辛苦了。

doitbest

我写的函数在常规数据量下应该是没有问题的，如果要进一步优化代码和算法，或者处理超大数据量感觉慢的话，可参考群子老师的相关代码

aman1516

谢谢分享，收藏学习