(vba编程excel实例)(用excel做仓库管理系统)

程序语言中的函数和数学中的函数基本概念是相似的。程序语言中的函数也有参数和返回值，以及定义和调用。程序中的函数，就是将一些程序语句结合在一起的部件，通过多次调用，函数可以不止一次地在程序中运行。

程序中使用函数的好处：

一是将大问题分解成许多小问题。函数可以将程序分成多个子程序段，开发者可以独立编写各个子程序，实现程序开发流程的分解。每个函数实现特定功能，我们可以针对这个函数来编写程序。计算机程序中，函数的实现千变万化。函数调用中，即使函数的实现改变了，只要函数的调用方式不变，调用它的程序就不用做任何改变。这种函数调用的结构，使得主程序精巧明了，使程序修改更加容易，程序结构变得具有一种排列紧凑、疏密得当的美感。

二是便于检测错误。一个函数写好后，我们会检测其实现的正确性。程序由多个函数组成的，我们确定每一个函数是正确后，总程序出错的可能性就会降低。另外函数的代码量小，也便于检测错误。

三是实现封装和重用。“封装”的意思是隐藏细节，应用时只需要传递相应的参数给函数，函数就会返回相应的结果，而不必关注函数操作的具体实现。“重用”的特点体现在，各个程序都可以直接调用已经写好的函数，而不用重复编写代码，这种重用提高了程序开发效率。

四是便于维护。每个函数都必须要有清楚的界面和注释，包含了功能，输入的参数、返回值的解释等。让人知道如何调用这个函数。

实际上，系统提供的函数与用户自定义函数本质上是一样的，只是前者显得更专业，速度可能快一些罢了。

对于EXCEL—VBA来说，代码往往是短小精悍的，自定义函数就非必须。但中等以上的代码量也很常见，自定义函数就能够体现出其价值。而且，从成为一个资深代码开发者的标准来看，自定义函数的知识储备与应用习惯的培养，也是必须的。

以下和大家分享一组自认为实用价值较高的自定义函数，当然函数代码仍有进一步优化的余地，这里只是抛砖引玉，开启思路，谨供参考。函数中的说明语句如果不够明确，可结合示例文件加深理解。

1、字典排序程序和字典排序数组

字典排序本质上也就是数组排序，但由于其有自己的特点和特殊应用，因此单独写了字典排序程序和函数。字典排序程序是带参数的程序，本质上仍是函数，调用执行后字典将处于排序后的状态。字典排序函数是将排序后的字典写入数组，方便下步调用。

Public Function sortdictoarr(d, key, order)

Rem 将排序后的字典写入数组

Rem 参数1为字典对象，参数2为排序关键字（1为字典键，2为字典值），参数3为升降序种类（1为升序，2为降序）

Dim ar, brr(), tmp0, tmp1, tmp2, ii, i, code, quot

ke = d.keys

it = d.items

If key = 1 Then ar = ke Else ar = it

If order = 1 Then code = "<" Else code = ">"

ReDim brr(1 To d.count, 1 To 2)

For i = 0 To UBound(ar) - 1

For ii = i + 1 To UBound(ar)

If TypeName(ar(0)) = "String" Then quot = Chr(34) Else quot = ""

tmp = Evaluate(quot & ar(ii) & quot & code & quot & ar(i) & quot)

If tmp = True Then

tmp0 = ar(i): ar(i) = ar(ii): ar(ii) = tmp0

tmp1 = it(i): it(i) = it(ii): it(ii) = tmp1

tmp2 = ke(i): ke(i) = ke(ii): ke(ii) = tmp2

End If

Next

Next

For i = 0 To UBound(ke)

brr(i + 1, 1) = ke(i)

brr(i + 1, 2) = it(i)

Next

sortdictoarr = brr

End Function

Public Sub sortdic(d, key, order)

Rem 字典排序程序

Rem 参数1为字典对象，参数2为排序关键字（1为字典键，2为字典值），参数3为升降序种类（1为升序，2为降序）

Dim ar, tmp0, tmp1, tmp2, ii, i, code, quot

ke = d.keys

it = d.items

If key = 1 Then ar = ke Else ar = it

If order = 1 Then code = "<" Else code = ">"

For i = 0 To UBound(ar) - 1

For ii = i + 1 To UBound(ar)

If TypeName(ar(0)) = "String" Then quot = Chr(34) Else quot = ""

tmp = Evaluate(quot & ar(ii) & quot & code & quot & ar(i) & quot)

If tmp = True Then

tmp0 = ar(i): ar(i) = ar(ii): ar(ii) = tmp0

tmp1 = it(i): it(i) = it(ii): it(ii) = tmp1

tmp2 = ke(i): ke(i) = ke(ii): ke(ii) = tmp2

End If

Next

Next

d.RemoveAll

For i = 0 To UBound(ke) '将排序后的数组重新写入字典

d(ke(i)) = it(i)

Next

End Sub

2、数组排序函数

VBA没有为我们提供数组排序功能，这是一个缺憾。实际开发中，人们或者书写冗长的排序语句，或者干脆用单元格排序语句来变通代替，也可勉强解决问题，二者的弊端显而易见。此函数可实现最多三个关键字的排序，基本满足实战需要。如有更多关键字排序需求的，可根据此代码思路，进一步深化函数的功能。

Public Function sortarr(arr, key1, order1, Optional key2 = 0, Optional order2 = 1, Optional key3 = 0, Optional order3 = 1)

Rem 数组排序函数

Rem arr为被排序数组，含key参数为排序字段，含order参数为排序次序，key和order两两一组，最多三组，最多可对三个字段排序，后两组排序参数可省略

Dim i, ii, c, code, tmp, code1, code2, tmparr(), v1, v2, v3, v4, v5, v6, tmp0, tmp1, tmp2, tmp3, tmp4

If LBound(arr) = 0 Then

Rem 一维数组排序

If order1 = 1 Then code = "<" Else code = ">"

For i = 0 To UBound(arr) - 1

For ii = i + 1 To UBound(arr)

tmp = Evaluate(arr(ii) & code & arr(i))

If tmp = True Then tmp1 = arr(i): arr(i) = arr(ii): arr(ii) = tmp1

Next

Next

Else

Rem 二维数组排序

ReDim tmparr(1 To UBound(arr, 2))

If key2 = 0 And key3 = 0 Then

Rem 一个关键字排序

If order1 = 1 Then code1 = "<" Else code1 = ">"

For i = 1 To UBound(arr) - 1

For ii = i + 1 To UBound(arr)

v1 = arr(ii, key1): v2 = arr(i, key1)

'evaluate括号中的字符串两面要加引号

If TypeName(arr(ii, key1)) = "String" Then v1 = """" & arr(ii, key1) & """"

If TypeName(arr(i, key1)) = "String" Then v2 = """" & arr(i, key1) & """"

tmp = Evaluate(v1 & code1 & v2)

If tmp = True Then

For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next

For c = 1 To UBound(arr, 2): arr(i, c) = arr(ii, c): Next

For c = 1 To UBound(arr, 2): arr(ii, c) = tmparr(c): Next

End If

Next

Next

ElseIf key2 <> 0 And key3 = 0 Then

Rem 两个关键字排序

If order1 = 1 Then code1 = "<" Else code1 = ">"

If order2 = 1 Then code2 = "<" Else code2 = ">"

For i = 1 To UBound(arr) - 1

For ii = i + 1 To UBound(arr)

v1 = arr(ii, key1): v2 = arr(i, key1)

If TypeName(arr(ii, key1)) = "String" Then v1 = """" & arr(ii, key1) & """"

If TypeName(arr(i, key1)) = "String" Then v2 = """" & arr(i, key1) & """"

tmp1 = Evaluate(v1 & code1 & v2)

tmp0 = Evaluate(v1 & "=" & v2)

v3 = arr(ii, key2): v4 = arr(i, key2)

If TypeName(arr(ii, key2)) = "String" Then v3 = """" & arr(ii, key2) & """"

If TypeName(arr(i, key2)) = "String" Then v4 = """" & arr(i, key2) & """"

tmp2 = Evaluate(v3 & code2 & v4)

If tmp1 = True Or (tmp0 = True And tmp2 = True) Then

For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next

For c = 1 To UBound(arr, 2)

arr(i, c) = arr(ii, c)

Next

For c = 1 To UBound(arr, 2)

arr(ii, c) = tmparr(c)

Next

End If

Next

Next

ElseIf key2 <> 0 And key3 <> 0 Then

Rem 三个关键字排序

If order1 = 1 Then code1 = "<" Else code1 = ">"

If order2 = 1 Then code2 = "<" Else code2 = ">"

If order3 = 1 Then code3 = "<" Else code3 = ">"

For i = 1 To UBound(arr) - 1

For ii = i + 1 To UBound(arr)

v1 = arr(ii, key1): v2 = arr(i, key1)

If TypeName(arr(ii, key1)) = "String" Then v1 = """" & arr(ii, key1) & """"

If TypeName(arr(i, key1)) = "String" Then v2 = """" & arr(i, key1) & """"

tmp1 = Evaluate(v1 & code1 & v2)

tmp0 = Evaluate(v1 & "=" & v2)

v3 = arr(ii, key2): v4 = arr(i, key2)

If TypeName(arr(ii, key2)) = "String" Then v3 = """" & arr(ii, key2) & """"

If TypeName(arr(i, key2)) = "String" Then v4 = """" & arr(i, key2) & """"

tmp2 = Evaluate(v3 & "=" & v4)

tmp3 = Evaluate(v3 & code2 & v4)

v5 = arr(ii, key3): v6 = arr(i, key3)

If TypeName(arr(ii, key3)) = "String" Then v5 = """" & arr(ii, key3) & """"

If TypeName(arr(i, key3)) = "String" Then v6 = """" & arr(i, key3) & """"

tmp4 = Evaluate(v5 & code2 & v6)

If tmp1 = True Or (tmp0 = True And tmp3 = True) Or (tmp0 = True And tmp2 = True And tmp4 = True) Then

For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next

For c = 1 To UBound(arr, 2)

arr(i, c) = arr(ii, c)

Next

For c = 1 To UBound(arr, 2)

arr(ii, c) = tmparr(c)

Next

End If

Next

Next

End If

End If

sortarr = arr

End Function

3、条件求和函数

相当于sumifs函数，但该函数在2007版本以上才有，且不能处理数组。此函数试用没有问题，但由于条件表达式多种多样，因此不敢保证在所有情况下，函数执行绝对无误。大家在应用中如发现问题，可在本贴中反馈。

Public Function sumifs(arr, c, ParamArray Other())

Rem 数组条件求和

Rem 参数1为待计算数组，参数2为被求和数组列号，参数3、4分别为比对条件列号和条件，参数5、6作用与参数3、4相同，从参数5、6开始可以设置多组条件，也可省略，类似sumifs工作表函数

Dim reg As Object, str, i, ii, n, num, he, s1, s2, s0

Set reg = CreateObject("vbscript.regexp")

reg.Global = True

reg.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)(%?)$"

he = 0

If LBound(arr) = 0 Then

Rem 一维数组

For i = 0 To UBound(arr)

If reg.test(Other(0)) = True Then

s0 = reg.Execute(Other(0))(0).submatches(0)

s1 = reg.Execute(Other(0))(0).submatches(1)

s2 = reg.Execute(Other(0))(0).submatches(2)

If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(0) '求和条件中的百分比要转化为数值，系统方能识别

If s0 = "" Then str = "=" & str

If Evaluate(arr(i) & str) Then he = he + arr(i) '计算条件为数值

Else

If arr(i) Like Other(0) Then he = he + arr(i) '计算条件为字符串和通配符

End If

Next

Else

Rem 二维数组

For i = 1 To UBound(arr)

For ii = 1 To UBound(Other) Step 2

If reg.test(Other(ii)) = True Then

s0 = reg.Execute(Other(ii))(0).submatches(0)

s1 = reg.Execute(Other(ii))(0).submatches(1)

s2 = reg.Execute(Other(ii))(0).submatches(2)

If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(ii)

If s0 = "" Then str = "=" & str

If Evaluate(arr(i, Other(ii - 1)) & str) Then n = n + 1: str = ""

Else

If arr(i, Other(ii - 1)) Like Other(ii) Then n = n + 1

End If

Next

If n = (UBound(Other) + 1) / 2 Then he = he + arr(i, c) '满足所有条件，则进行累加

n = 0

Next

End If

sumifs = he

End Function

4、条件计数函数和条件求平均值函数

相当于countifs和averageifs函数，这两个函数与条件求和函数代码思路大同小异，不加细说。

Public Function countifs(arr, ParamArray Other())

Rem 数组条件计数函数

Rem 参数说明请参考sumifs函数

Dim reg As Object, str, i, ii, n, num, times, s1, s2, s0

Set reg = CreateObject("vbscript.regexp")

reg.Global = True

reg.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)(%?)$"

he = 0

times = 0

If LBound(arr) = 0 Then

Rem 一维数组

For i = 0 To UBound(arr)

If reg.test(Other(0)) = True Then

s0 = reg.Execute(Other(0))(0).submatches(0)

s1 = reg.Execute(Other(0))(0).submatches(1)

s2 = reg.Execute(Other(0))(0).submatches(2)

If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(0)

If s0 = "" Then str = "=" & str

If Evaluate(arr(i) & str) Then times = times + 1

Else

If arr(i) Like Other(0) Then times = times + 1

End If

Next

Else

Rem 二维数组

For i = 1 To UBound(arr)

For ii = 1 To UBound(Other) Step 2

If reg.test(Other(ii)) = True Then

s0 = reg.Execute(Other(ii))(0).submatches(0)

s1 = reg.Execute(Other(ii))(0).submatches(1)

s2 = reg.Execute(Other(ii))(0).submatches(2)

If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(ii)

If s0 = "" Then str = "=" & str

If Evaluate(arr(i, Other(ii - 1)) & str) Then n = n + 1: str = ""

Else

If arr(i, Other(ii - 1)) Like Other(ii) Then n = n + 1

End If

Next

If n = (UBound(Other) + 1) / 2 Then times = times + 1

n = 0

Next

End If

countifs = times

End Function

Public Function averageifs(arr, c, ParamArray Other())

Rem 数组条件求和

Rem 参数说明请参考sumifs函数

Dim reg As Object, str, i, ii, n, num, he, s1, s2, s0, times

Set reg = CreateObject("vbscript.regexp")

reg.Global = True

reg.Pattern = "^([><=]{0,2})(-?\d*\.?\d*)(%?)$"

he = 0

If LBound(arr) = 0 Then

Rem 一维数组

For i = 0 To UBound(arr)

If reg.test(Other(0)) = True Then

s0 = reg.Execute(Other(0))(0).submatches(0)

s1 = reg.Execute(Other(0))(0).submatches(1)

s2 = reg.Execute(Other(0))(0).submatches(2)

If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(0)

If s0 = "" Then str = "=" & str

If Evaluate(arr(i) & str) Then he = he + arr(i): times = times + 1

Else

If arr(i) Like Other(0) Then he = he + arr(i): times = times + 1

End If

Next

Else

Rem 二维数组

For i = 1 To UBound(arr)

For ii = 1 To UBound(Other) Step 2

If reg.test(Other(ii)) = True Then

s0 = reg.Execute(Other(ii))(0).submatches(0)

s1 = reg.Execute(Other(ii))(0).submatches(1)

s2 = reg.Execute(Other(ii))(0).submatches(2)

If s2 = "%" Then str = s0 & (s1 - 0) / 100 Else str = Other(ii)

If s0 = "" Then str = "=" & str

If Evaluate(arr(i, Other(ii - 1)) & str) Then n = n + 1: str = ""

Else

If arr(i, Other(ii - 1)) Like Other(ii) Then n = n + 1

End If

Next

If n = (UBound(Other) + 1) / 2 Then he = he + arr(i, c): times = times + 1

n = 0

Next

End If

averageifs = he / times

End Function

5、数组重排列函数

数组重排列函数在应用中比较普遍，存在多行多列数组与多行多列、一行多列、一列多行数组之间相互转换等多种变化，本函数基本能够以上各种可能。

Public Function trans(arr, Optional r = 0, Optional c = 0)

Rem 数组重排列函数

Rem 参数1为待排列数组，参数2为目标数组行数，参数3为目标数组列数。如对一维数组排列可只有一个参数，如对二维数组排列参数2、3只输入一个即可

Dim r1, c1, n, nn, brr(), tmp, count

If LBound(arr) = 0 Then

If r > 0 Then c = Application.RoundUp((UBound(arr) + 1) / r, 0): GoTo 100

If c > 0 Then r = Application.RoundUp((UBound(arr) + 1) / c, 0)

100:

ReDim brr(1 To r, 1 To c)

For c1 = 1 To c

For r1 = 1 To r

brr(r1, c1) = arr(n)

n = n + 1

If n > UBound(arr) Then Exit For

Next

Next

Else

tmp = UBound(arr) * UBound(arr, 2)

If r > 0 Then c = Application.RoundUp(tmp / r, 0): GoTo 200

If c > 0 Then r = Application.RoundUp(tmp / c, 0)

200:

ReDim brr(1 To r, 1 To c)

nn = 1

For c1 = 1 To c

For r1 = 1 To r

n = n + 1

count = count + 1

If count > tmp Then Exit For

If n > UBound(arr) Then n = 1: nn = nn + 1

brr(r1, c1) = arr(n, nn)

Next

Next

End If

trans = brr

End Function

6、数组随机排列函数

Public Function sortarrbyrnd(arr)

Rem 数组随机排序函数

Dim r, c, i, ii, brr(), tmp1, tmp2, tmparr

Randomize

If LBound(arr) = 0 Then '一维数组随机排序

ReDim brr(0 To UBound(arr))

For i = 0 To UBound(brr) '将随机值写入辅助数组BRR，作为排序依据

brr(i) = Rnd

Next

For i = 0 To UBound(brr) - 1

For ii = i + 1 To UBound(brr)

If brr(ii) < brr(i) Then

tmp1 = brr(i): brr(i) = brr(ii): brr(ii) = tmp1

tmp2 = arr(i): arr(i) = arr(ii): arr(ii) = tmp2

End If

Next

Next

Else '二维数组随机排序

ReDim brr(1 To UBound(arr))

ReDim tmparr(1 To UBound(arr, 2))

For i = 1 To UBound(brr)

brr(i) = Rnd

Next

For i = 1 To UBound(brr) - 1

For ii = i + 1 To UBound(brr)

If brr(ii) < brr(i) Then

tmp1 = brr(i): brr(i) = brr(ii): brr(ii) = tmp1

For c = 1 To UBound(arr, 2): tmparr(c) = arr(i, c): Next

For c = 1 To UBound(arr, 2): arr(i, c) = arr(ii, c): Next

For c = 1 To UBound(arr, 2): arr(ii, c) = tmparr(c): Next

End If

Next

Next

End If

sortarrbyrnd = arr

End Function

7、生成连续值判断数组函数

这里连续值定义为等比、等差序列，及其变异种类，函数结果生成一个包含连续序列起止位置的嵌套函数，方便下一步的个性化应用。

Public Function 连续值数组(arr, typenum, interval)

Rem 生成类如" array(array(a,b),array(c,d),array(e,f)) "结构的嵌套数组,例如a、b值分别为一个连续系列的起止位置

Rem 参数1为待判断数组，参数2（1为等差数列，2为等比数列），参数3为等差或等比数列的步长值

Dim brr(), i, a0, a1, flag, n, reg As Object, tmp0, tmp1, code, times

Set reg = CreateObject("vbscript.regexp")

reg.Global = True

reg.Pattern = "\d+"

If typenum = 1 Then code = "-" Else code = "/"

For i = 2 To UBound(arr)

tmp0 = Val(reg.Execute(arr(i - 1, 1))(0))

tmp1 = Val(reg.Execute(arr(i, 1))(0))

If Evaluate(tmp1 & code & tmp0) = interval Then

If flag = 0 Then a0 = i - 1: flag = 1

a1 = i

If i = UBound(arr) Then

If flag = 1 Then

times = times + 1

ReDim Preserve brr(1 To times)

brr(times) = Array(a0, a1)

End If

End If

Else

If flag = 1 Then

times = times + 1

ReDim Preserve brr(1 To times)

brr(times) = Array(a0, a1)

End If

flag = 0

End If

Next

连续值数组 = brr

End Function

8、排名函数

如同许多工作表函数一样，RANK函数也不支持数组，更不可能实现中国式排名，给应用者带来遗憾和困扰。此函数可实现常规排名和中国式排名，在编写排名程序时可直接调用。

Public Function rank(num, arr, column0, type0)

Rem 排名函数

Rem 参数1为待排名值，参数2为数字列表数组，参数3为数组中的排序列列号，参数4（1为常规排名，2为中国式排名）

Dim i, n, str

If type0 = 1 Then

For i = 1 To UBound(arr)

If arr(i, column0) > num Then n = n + 1

Next

ElseIf type0 = 2 Then

For i = 1 To UBound(arr)

If arr(i, column0) > num And InStr(vbCr & str & vbCr, vbCr & arr(i, column0) & vbCr) = 0 Then

str = str & vbCr & arr(i, column0)

n = n + 1

End If

Next

End If

rank = n + 1

End Function

9、简单透视表函数

通过透视处理，形成类似简单报表的数组，能够满足很多工作中的基本需求。SQL语句中有类似的转置功能，但用起来更麻烦，不如这个实用。

Public Function PivotTable(arr, rowfields, columnfields, datafields)

Rem 数组透视，将数组生成简单报表

Rem 参数1为待处理数组，参数2为报表行标题的数组列号，参数3为报表列标题的数组列号，参数4为报表数值区域的数组列号

Dim d1, d2, d3, brr(), str, k1, k2, i, ii

Set d1 = CreateObject("Scripting.Dictionary")

Set d2 = CreateObject("Scripting.Dictionary")

Set d3 = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(arr)

d1(arr(i, rowfields)) = "" '生成行标题字典

d2(arr(i, columnfields)) = "" '生成列标题字典

str = arr(i, rowfields) & vbCr & arr(i, columnfields)

d3(str) = d3(str) + arr(i, datafields)

Next

ReDim brr(1 To d1.count + 1, 1 To d2.count + 1)

k1 = d1.keys

k2 = d2.keys

For i = 2 To UBound(brr) '生成行标题

brr(i, 1) = k1(i - 2)

Next

For i = 2 To UBound(brr, 2) '生成列标题

brr(1, i) = k2(i - 2)

Next

For i = 2 To UBound(brr) '生成报表数值区域

For ii = 2 To UBound(brr, 2)

str = brr(i, 1) & vbCr & brr(1, ii)

brr(i, ii) = d3(str)

Next

Next

Set d1 = Nothing

Set d2 = Nothing

Set d3 = Nothing

PivotTable = brr

End Function

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

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

小伙伴，大家一起学习Excel VBA知识，一起进步。同时欢迎大家帮忙转发并关注，谢谢大家的支持！