Excel·VBA数组组合函数、组合求和
目录
-
- 1，组合代码思路
- 2，VBA数组组合函数（返回二维数组）
- 3，组合求和（利用二维数组）
- 4，VBA数组组合函数（返回一维嵌套数组）
- 5，VBA组合求和（利用一维嵌套数组）
《百度百科-组合》
组合、组合数：从n个不同元素中，任取m(m≤n)个元素并成一组，叫做从n个不同元素中取出m个元素的一个组合；从n个不同元素中取出m(m≤n)个元素的所有组合的个数，叫做从n个不同元素中取出m个元素的组合数
组合个数公式：C(n,m)=n!/(m!(n-m)!)
1，组合代码思路
从1-7共7个数字中选出5个数字，共21种组合，如图
观察每个组合的数字排列规律，可以发现每次最后一个数字排列到尾数7的时候，前面一个数字递增1，后面依次排列到尾数7；且后面的几个数字如果存在依次递增的情况时，前面的一个数字递增1，后面依次排列到尾数7，直至完成21种组合
VBA代码如下
2，VBA数组组合函数（返回二维数组）
Function combin_arr(arr, n&)
'arr一维数组，内含m个元素，抽取n个进行组合，返回二维数组，每行为一个组合(数组从1开始计数)
Dim i&, j&, k&, l&, m&, kk&, t&, temp
If LBound(arr) = 0 Then '转为从1开始计数
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
End If
If n = 1 Then combin_arr = WorksheetFunction.Transpose(arr): Exit Function
m = UBound(arr) - LBound(arr) + 1
kk = Application.Combin(m, n)
ReDim brr(1 To kk, 1 To n)
ReDim a&(1 To n)
For j = 1 To n - 1
a(j) = j
Next
i = n - 1: k = 0 ': j = n '上面for结束后j=n；加不加j = n都一样
Do
For i = a(n - 1) + 1 To m '仅修改最后一位
a(n) = i
k = k + 1
For l = 1 To n
brr(k, l) = arr(a(l))
Next
Next
If a(n - 1) <> a(n) - 1 And a(n) = m Then
a(n - 1) = a(n - 1) + 1
ElseIf a(n - 1) = a(n) - 1 And a(n) = m Then
For t = n - 1 To 1 Step -1 'a(j)进步，避免n=2情况报错，因而只n-1
If a(t) <> a(t + 1) - 1 Then
temp = a(t) + 1: a(t) = temp: t = t + 1
Do Until t = n '为真退出，先判断；最后一位不修改
a(t) = a(t - 1) + 1: t = t + 1
Loop
Exit For
End If
Next
End If
Loop Until k = kk
combin_arr = brr
End Function
以上代码及思路，部分参考excelhome大神“香川群子”，原版代码如下
Function CombinArr(arr, n&)
'arr一维数组，内含m个元素，抽取n个进行组合，返回二维数组，每行为一个组合(数组从1开始计数)
'源代码by kagawa，https://club.excelhome.net/?218774
Dim i&, j&, k&, l&, m&
m = UBound(arr) - LBound(arr) + 1
k = Application.Combin(m, n)
ReDim brr(1 To k, 1 To n)
ReDim a&(1 To n)
For j = 1 To n - 1
a(j) = j
Next
i = n - 1: k = 0 ': j = n
Do
For i = i + 1 To m
a(j) = i
k = k + 1
For l = 1 To n
brr(k, l) = arr(a(l))
Next
Next
For j = j - 1 To 1 Step -1
i = a(j) + 1: a(j) = i
If i = m - n + j Then
k = k + 1
For l = 1 To n
brr(k, l) = arr(a(l))
Next
Else
j = j + 1
Do Until j = n
i = i + 1: a(j) = i: j = j + 1
Loop
If i = m Then Exit Do Else Exit For
End If
Next
Loop Until j = 0
CombinArr = brr
End Function
以上2种代码写法输出效果一致，耗时基本一致
测试在excel表格中输出1-16共16个数字的全组合形式，共65535种组合，用时都为1秒
Private Sub combin_arr测试()
Dim arr, brr, i&, r&
tm = Now()
arr = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr)) '从1开始计数一维数组
[a1] = "全组合"
For i = 1 To UBound(arr)
brr = combin_arr(arr, i)
r = Cells(1, "a").CurrentRegion.Rows.count + 1
Cells(r, "a").Resize(UBound(brr), UBound(brr, 2)) = brr
Next
Debug.Print ("组合用时" & Format(Now() - tm, "hh:mm:ss")) '耗时
Debug.Print ("组合用时" & Format(Now() - tm, "###0.0000000000")) '耗时
End Sub
3，组合求和（利用二维数组）
组合最常见的应用就是从一堆数字中凑金额，即组合求和
举例：从A列19个数字中选取6个数字，使其和为39085，在右侧输出结果
Function TransposeArr(data_arr, Optional res As Long = 1)
'二维数组与一维嵌套数组互相转换函数，data_arr和返回数组从1开始计数
Dim i&, j&, result
If res = 1 Then '转为一维嵌套数组
ReDim result(1 To UBound(data_arr) - LBound(data_arr) + 1)
For i = LBound(data_arr) To UBound(data_arr)
temp = Application.index(data_arr, i)
j = j + 1: result(j) = temp
Next
TransposeArr = result
ElseIf res = 2 Then '转为二维数组
Dim rr&, cc&, r&, c&, tmp&
rr = UBound(data_arr) - LBound(data_arr) + 1
For Each a In data_arr
tmp = UBound(a) - LBound(a) + 1
If tmp > cc Then cc = tmp
Next
ReDim result(1 To rr, 1 To cc)
For Each a In data_arr
r = r + 1: c = 0
For i = LBound(a) To UBound(a)
c = c + 1: result(r, c) = a(i)
Next
Next
TransposeArr = result
End If
End Function
Sub 组合求和()
Dim m&, n&, h, j&, arr, brr, crr
tm = Timer
m = [a1].End(xlDown).row - 1 '待组合元素个数
n = [b4] '组合个数
h = [b2] '目标和值
arr = [a2].Resize(m): arr = WorksheetFunction.Transpose(arr) '单列转一维数组
'--------------------原生函数返回二维数组
' brr = combin_arr(arr, n) '调用函数返回组合，二维数组
' For j = 1 To UBound(brr) '遍历数组
' temp = Application.index(brr, j): temp_sum = WorksheetFunction.Sum(temp)
' If temp_sum = h Then
' r = Cells(65535, "i").End(xlUp).row + 1
' Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(temp, "+"))
' End If
' Next
'--------------------一维嵌套数组，遍历方法1
crr = TransposeArr(brr) '''调用函数，将二维数组转为一维嵌套数组
' For j = 1 To UBound(crr)
' temp_sum = WorksheetFunction.Sum(crr(j))
' If temp_sum = h Then
' r = Cells(65535, "i").End(xlUp).row + 1
' Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(crr(j), "+"))
' End If
' Next
'--------------------一维嵌套数组，遍历方法2，速度无影响
For Each c In crr
temp_sum = WorksheetFunction.Sum(c)
If temp_sum = h Then
r = Cells(65535, "i").End(xlUp).row + 1
Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(c, "+"))
End If
Next
Debug.Print ("组合求和完成，累计用时：" & Format(Timer - tm, "0.00")) '耗时
End Sub
测试结果：共27132个组合，耗时秒数
| 二维数组 | 一维嵌套数组1 | 一维嵌套数组2 |
|---|---|---|
| 241 | 243 | 239 |
显然速度非常慢，那么数组组合函数直接生成一维嵌套数组时，组合求和速度能否提高呢？
4，VBA数组组合函数（返回一维嵌套数组）
Function combin_arr1(arr, n&)
'arr一维数组，内含m个元素，抽取n个进行组合，返回一维嵌套数组，每行为一个组合(数组从1开始计数)
Dim i&, j&, k&, l&, m&, kk&, t&, temp
If LBound(arr) = 0 Then '转为从1开始计数
arr = WorksheetFunction.Transpose(WorksheetFunction.Transpose(arr))
End If
m = UBound(arr) - LBound(arr) + 1
kk = Application.Combin(m, n): ReDim brr(1 To kk)
If n = 1 Then
For i = 1 To m
brr(i) = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Array(arr(i))))
Next
combin_arr1 = brr: Exit Function
End If
ReDim a&(1 To n), b(1 To n)
For j = 1 To n - 1
a(j) = j
Next
i = n - 1: k = 0 ': j = n '上面for结束后j=n，加不加j = n都一样
Do
For i = a(n - 1) + 1 To m '仅修改最后一位
a(n) = i
For l = 1 To n
b(l) = arr(a(l))
Next
k = k + 1: brr(k) = b
Next
If a(n - 1) <> a(n) - 1 And a(n) = m Then
a(n - 1) = a(n - 1) + 1
ElseIf a(n - 1) = a(n) - 1 And a(n) = m Then
For t = n - 1 To 1 Step -1 'a(j)进步，避免n=2情况报错，因而只n-1
If a(t) <> a(t + 1) - 1 Then
temp = a(t) + 1: a(t) = temp: t = t + 1
Do Until t = n '为真退出，先判断；最后一位不修改
a(t) = a(t - 1) + 1: t = t + 1
Loop
Exit For
End If
Next
End If
Loop Until k = kk
combin_arr1 = brr
End Function
Sub 组合求和1()
Dim m&, n&, h, j&, arr, brr, crr
tm = Timer
m = [a1].End(xlDown).row - 1 '待组合元素个数
n = [b4] '组合个数
h = [b2] '目标和值
arr = [a2].Resize(m): arr = WorksheetFunction.Transpose(arr) '单列转一维数组
brr = combin_arr1(arr, n) '调用函数返回组合，一维嵌套数组
For Each b In brr
temp_sum = WorksheetFunction.Sum(b)
If temp_sum = h Then
r = Cells(65535, "i").End(xlUp).row + 1
Cells(r, "i").Resize(1, 3) = Array(n, temp_sum, Join(b, "+"))
End If
Next
Debug.Print ("组合求和完成，累计用时：" & Format(Timer - tm, "0.00")) '耗时
End Sub
测试结果：共27132个组合，耗时仅0.12秒，比二维数组快了2000倍
5，VBA组合求和（利用一维嵌套数组）
Sub 组合求和()
Dim m&, n&, n2&, h, h2, i&, arr, brr
tm = Timer
'参数检查、获取
If Len([b2]) = 0 Then Debug.Print "B2不得为空": Exit Sub
m = [a1].End(xlDown).row - 1 '【待组合元素个数m】
n = [b4]: n2 = [b5]: If n2 = 0 Then If n = 0 Then n = 1: n2 = m Else n2 = n '【组合个数范围】[n,n2]
If n = 0 Then n = 1 '情况：n=0, n2=自然数
h = [b2]: h2 = [b3]: If Len(h2) = 0 Then h2 = h '【目标和值范围】[h,h2]
arr = [a2].Resize(m): arr = WorksheetFunction.Transpose(arr) '单列转一维数组
For i = n To n2
brr = combin_arr1(arr, i) '调用函数返回组合，一维嵌套数组
For Each b In brr
temp_sum = WorksheetFunction.Sum(b)
If temp_sum >= h And temp_sum <= h2 Then
r = Cells(65535, "i").End(xlUp).row + 1
Cells(r, "i").Resize(1, 3) = Array(i, temp_sum, Join(b, "+"))
End If
Next
Next
Debug.Print ("组合求和完成，累计用时：" & Format(Timer - tm, "0.00")) '耗时
End Sub
测试结果：全组合2^19-1共5242887个组合，耗时仅2.67秒