Excel VBA 字母组合/自定义函数组合数组元素/数组元素花样组合
???本文于2023年5月5日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！
☆本期内容概要☆
- 自定义函数-数组元素组合
- 正则表达式：字母、数字
- 解决问题的思路
今天无意间上了ExcelHome论坛，看到有个求助的贴子：
老朋友有没有想起什么？对了，我以前分享过一篇文章就是讲组合的：Excel VBA 数组应用/核算项目代码组合/VBA代码优化/AI辅助
我想这可以弄一下嘛。于是下载来附件一看，需求还比较特殊：
不管怎么样，还是来试一试吧，看看能不能帮到楼主。
需求分析及实现过程：
一、所有组合：
这个好办，用我们的自定义函数CombineArray，于是直接用它来组合，先测试一下存到数组里看看，哪知道还是图样图深破了，直接死机，半天不动。无奈强行退出重来，这次把字母区域选少一点，可以正常组合，这才放下心来。
但这样的速度明显不行啊，于是把代码再检查一遍，估计问题出在后半段数组排序过程：
上面这段给删掉，果然很快就组合好了。
二、固定长度组合：
首先想到的是，循环遍历数组，把指定长度的元素给提取出来，存到另一个数组中，于是测试了一下，没有问题：
arrTem = CombineArray(arrResult, "")
Erase arrResult
For i = LBound(arrTem) To UBound(arrTem)
If Len(arrTem(i)) = xLen Then
ReDim Preserve arrResult(k)
arrResult(k) = arrTem(i)
k = k + 1
End If
Next代码简析：数组arrResult()在前面存有数据，现在把它清空再使用。xLen是定义的一个变量，用来存放输入的组合长度。接着循环arrTem()，把长度等于xLen的元素存入arrResult()，这里采用ReDim Preserve的方法。（这段代码后来是不用了，采用另外的方法了。）
后来一想，这样是不是有点浪费资源？可不可以在组合过程中就直接得出固定长度的组合？于是就请教AI，它给了几段代码，测试不起作用，于是就另想它法了。
最后想到的方案是，在全部组合过程中，检查一下组合的元素长度，如果等于给定长度就存下来，否则就丢弃。最终修改后的自定义组合函数：
Function CombineArr(arr As Variant, Optional delimiter As String = "/", Optional length As Integer = 0) As Variant
'将一个数组中的所有元素进行组合
Dim n As Long, i As Long, j As Long, k As Long, count As Long
Dim result(), temp As String
n = UBound(arr) - LBound(arr) + 1 ' 计算数组长度
count = 2 ^ n - 1 ' 计算组合数
For i = 1 To count ' 遍历所有组合
temp = ""
For j = 0 To n - 1
If i And 2 ^ j Then ' 根据位运算判断元素是否参与组合
temp = temp & arr(LBound(arr) + j) & delimiter ' 将元素值拼接为字符串
End If
Next
temp = Left(temp, Len(temp) - Len(delimiter)) ' 去掉字符串末尾的分隔符
If length > 0 Then
If Len(temp) = length + Len(delimiter) * (length - 1) Then
ReDim Preserve result(r)
result(r) = temp
r = r + 1
End If
Else
ReDim Preserve result(r)
result(r) = temp
r = r + 1
End If
Next
CombineArr = result ' 返回结果数组
End Function代码简析：
这个自定义函数有两个参数：分隔符(delimiter)，默认为“/”，在今天的应用中，我们给它的值为空，就没有分隔符了，直接连到一起；组合元素长度(length )，默认为0，表示所有组合，但今天的应用中，它不能小于2。
通过位运算来取得组合元素temp（位运算是一种算法，具体怎么回事有待研究学习）。
判断函数的参数length，如果大于0，则继续判断temp的长度，这里要考虑分隔符的长度。符合长度条件的存入数组。如果length=0，则输出所有组合。
三、开头与结尾不可以是“1,3,5,6,8”，我们可以理解为不能是数字。
这个我们可以再分析，它的意思可以表述为：首尾必须是字母，也就是说，这个元素长度至少为2，至少2个字母，因为是组合，在组合时不考虑顺序，所以，如果包括数字的元素，如果开头、结尾是数字的，我们要把它放到字母中间，这样的元素也是符合条件的。
我们别自己费脑筋了，请教一下AI吧：
有了这段代码做参考，我理出了实现思路：
1、循环遍历数组，使用正则表达式来判断元素是否包括两个及以上字母；
2、再利用正则表达达判断元素的开头、结尾字符是否为数字；
3、如果是数字的，就从开头或结尾开始循环，找到第一个非数字的字符，将它与开头或结尾的数字互换位置。这个过程有点小复杂，我把字符串元素拆分成单个字符存到数组，再循环数组来调换位置，再连接成字符串。这里又定义了两个函数：
（1）字符串拆分成单个字符，存入数组
Function strSplit(str As Variant) As Variant
Dim arr()
For i = 1 To Len(str)
ReDim Preserve arr(i - 1)
arr(i - 1) = Mid(str, i, 1)
Next
strSplit = arr
End Function代码简析：从1开始循环字符串长度，依次截取字符，存入数组。
（2）调整字符位置的函数，连带舍弃仅有1个、0个字母的元素。
Function AdjustElements(arr As Variant) As Variant
Dim arrTem()
Dim regEx As Object
Dim NewElem As String
Dim arrResult()
Dim strA As String, strB As String, strT As String
Set regEx = CreateObject("VBScript.RegExp")
With regEx
.Pattern = "[a-zA-Z].*[a-zA-Z]"
.Global = True
End With
For i = LBound(arr) To UBound(arr)
regEx.Pattern = "[a-zA-Z].*[a-zA-Z]"
If regEx.test(arr(i)) Then
strA = Left(arr(i), 1): strB = Right(arr(i), 1)
regEx.Pattern = "[0-9]"
If regEx.test(strA) Then
arrTem = strSplit(arr(i))
For j = LBound(arrTem) To UBound(arrTem)
If Not regEx.test(arrTem(j)) Then
strT = arrTem(j)
arrTem(j) = strA
arrTem(LBound(arrTem)) = strT
Exit For
End If
Next
If regEx.test(strB) Then
For j = UBound(arrTem) To LBound(arrTem) Step -1
If Not regEx.test(arrTem(j)) Then
strT = arrTem(j)
arrTem(j) = strB
arrTem(UBound(arrTem)) = strT
Exit For
End If
Next
End If
NewElem = ""
For j = LBound(arrTem) To UBound(arrTem)
NewElem = NewElem & arrTem(j)
Next
ReDim Preserve arrResult(k)
arrResult(k) = NewElem
k = k + 1
ElseIf regEx.test(strB) Then
arrTem = strSplit(arr(i))
For j = UBound(arrTem) To LBound(arrTem) Step -1
If Not regEx.test(arrTem(j)) Then
strT = arrTem(j)
arrTem(j) = strB
arrTem(UBound(arrTem)) = strT
Exit For
End If
Next
NewElem = ""
For j = LBound(arrTem) To UBound(arrTem)
NewElem = NewElem & arrTem(j)
Next
ReDim Preserve arrResult(k)
arrResult(k) = NewElem
k = k + 1
Else
ReDim Preserve arrResult(k)
arrResult(k) = arr(i)
k = k + 1
End If
End If
Next
AdjustElements = arrResult
End Function代码简析：在前面的实现思路就基本阐述清楚了，好象也没什么可说的。有一个地方可以提一下，就是再次连接字符串的时候：
NewElem = ""
For j = LBound(arrTem) To UBound(arrTem)
NewElem = NewElem & arrTem(j)
Next可以用另一种方法，代码简洁一点：
NewElem = Replace(Join(arrTem), " ", "")原来我是用Join方法连接的，但看到中间有空格，也没多想，就换了循环数组的方法，后来想到这种方法，原代码就懒得改了。
四、最后完成代码执行
（一）新建一个过程CombineL()组合表格中的元素：
Sub CombineL()
Dim arr(), arrResult(), arrTem()
arr = Sheet1.Range("c9:c25")
arrResult = FlattenArray(arr)
arrTem = CombineArr(arrResult, "", xLen)
arrResult = AdjustElements(arrTem)
If xLen = 3 Then
Sheet1.Range("E9").Resize(UBound(arrResult) + 1, 1) = Application.WorksheetFunction.Transpose(arrResult)
ElseIf xLen = 5 Then
Sheet1.Range("F9").Resize(UBound(arrResult) + 1, 1) = Application.WorksheetFunction.Transpose(arrResult)
Else
Sheet1.Range("G9").Resize(UBound(arrResult) + 1, 1) = Application.WorksheetFunction.Transpose(arrResult)
End If
End Sub代码简析：
1、读取待组合区域的字符，存入arr（），转为一维数组
2、通过自定义函数CombineArr组合数组元素，存入arrTem（）
3、通过自定义函数AdjustElements再次处理数组元素，只有1个或0个字母的元素将被舍弃，开头结尾都调整成字母。结果存入arrResult数组
4、根据输入的组合元素长度，存到表格的相应单元格。
（二）在表格界面增加一个命令按钮CmdCombine（组合），输入代码：
Private Sub CmdCombine_Click()
xLen = Val(InputBox("请输入组合长度:", "组合长度", 3))
If xLen < 2 Then
MsgBox "组合元素长度必须大于等于2！"
Exit Sub
End If
Call CombineL
End Sub（三）点击组合按钮，输入组合元素长度，结果就出来啦：
好，今天就分享到这，由于时间仓促，代码可能存在错误，欢迎批评指正！请大家点赞、留言、分享，谢谢大家，我们下期再会。
☆猜你喜欢☆
Excel VBA 这样酷炫的日期控件，你不想要吗？ | Excel 公式函数/数据透视表/固定资产折旧计提表！ |
Excel VBA 自定义函数/数组字段定位/数组字段排序 | Excel 功能/公式函数/VBA/多种姿势处理重复值 |
Excel VBA 最简单的收发存登记系统 | Excel 公式函数/查找函数之LOOKUP |
Excel VBA 文件批量改名 | Excel 公式函数/数据验证/动态下拉列表 |
Excel VBA 输入逐步提示/TextBox+ListBox | Excel 基础功能【数据验证】，你会怎么用？ |
????本文于2023年5月5日首发于本人同名公众号：Excel活学活用，更多文章敬请关注！
