E列任意n个数相加等于28-VBA代码

zeng3915

各位大佬好，

请问怎么样用VBA代码算出E列任意2个，3个，4个，5个，6个，7个，8个，9个数相加=28。
举例1，2个数相加=28，结果是（目前人工检查发现没有2个数相加等于28的，但是实际上后期数据更改了，有可能会有的）
举例2，3个数相加=28，结果是E2+E3+E4，所以把对应的A列的型号放在H列，应该有很多种，把所有3个数相加的结果找出来后，隔1行放在H列
其他4个，5个，6个，7个，8个，9个的以此类推，我手动举了1个或多个例子放在G列至N列了。
我上传了图片和附件，可以下载看看，尽量算出更多的结果，因为后续我们需要根据型号算出最优解，结果多了，可能会得到最好的结果。
麻烦各位VBA大佬给点建议或者帮忙看看怎么结题吧，谢谢大佬啦！

zeng3915

有没有大佬愿意帮忙看看的，拜托拜托

gwjkkkkk

Option Explicit
Sub test()

    Dim vResult(), ar, br, cr, vTemp, r&, i&, j&, m&, n&, iCol&, bytDigit As Byte, dic As Object, vKey, t#
   
   
    Application.ScreenUpdating = False
    t = Timer
    bytDigit = 0
   
    iCol = 5
    r = Cells(Rows.Count, "A").End(xlUp).Row
    vTemp = Range("A2:E" & r).Value
    ar = Application.Index(vTemp, , iCol)
   
    ReDim Preserve ar(1 To UBound(ar), 1 To 2)
    For i = 1 To UBound(ar): ar(i, 2) = i: Next i
    bSort ar, 1, UBound(ar), 1, 2
   
    n = UBound(ar)
    ReDim br(1 To n)
    r = 0
    MakeNumCount vResult, ar, br, r, 28, bytDigit
   
    Set dic = CreateObject("Scripting.Dictionary")
    n = 0
    Columns("G:XFD").Clear
    If r Then
        ReDim ar(1 To UBound(vResult, 2), 1 To 2)
        For i = 1 To UBound(vResult, 2)
            ar(i, 1) = vResult(1, i)
            ar(i, 2) = vResult(2, i)
        Next i
        
        ShellSort2D ar, 1, UBound(ar), 1, 2, 1
        For i = 1 To UBound(ar)
            dic(ar(i, 1)) = dic(ar(i, 1)) & "|" & ar(i, 2)
        Next i
        
        For Each vKey In dic.keys
            n = n + 1
            br = Split(dic(vKey), "|")
            m = 1
            
            ReDim ar(1 To UBound(br) * (vKey + 1), 0)
            ar(m, 0) = vKey & "个相加结果等于28"
            For i = 1 To UBound(br)
                cr = Split(br(i), ",")
                For j = 0 To UBound(cr)
                    m = m + 1
                    ar(m, 0) = vTemp(cr(j), 1)
                Next j
                If i < UBound(br) Then m = m + 1
            Next i
            Cells(1, n + 6).Resize(m) = ar
            Columns(n + 6).AutoFit
        Next
    End If
   
    Application.ScreenUpdating = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒,共发现 " & r & " 组", 64
End Sub


Function MakeNumCount(ByRef vResult(), ByVal ar, ByVal br, ByRef iGroup&, ByVal iSum&, ByVal bytDigit As Byte, Optional ByVal iCount& = 0, _
    Optional ByVal iEleNum& = 0, Optional ByVal iTemp& = 0, Optional ByVal iStart& = 1, Optional ByVal iChkNum& = -1)
    Dim i&, j&, iNum&, cr(), strJoin$, r&, m&
     
    iChkNum = iChkNum + 1
    If iEleNum * (iEleNum = iChkNum) Then Exit Function
   
    For i = iStart To UBound(br)
        If iCount * (iGroup = iCount) Then Exit Function
        
        iNum = ar(i, 1) * 10 ^ bytDigit: br(i) = iNum
        If iTemp + iNum > iSum Then Exit Function
            
        If iTemp + iNum = iSum Then
            r = 0:  strJoin = ""
            For j = 1 To UBound(br)
                If br(j) <> "" Then
                    strJoin = strJoin & IIf(br(j) < 0, "", "+") & br(j) * 10 ^ -bytDigit
                    r = r + 1
                    ReDim Preserve cr(1 To r)
                    cr(r) = ar(j, 2)
                 End If
            Next j
            
            m = IIf(iEleNum = 0, r, iEleNum)
            If r = m Then
                iGroup = iGroup + 1
                ReDim Preserve vResult(1 To 2, 1 To iGroup)
                vResult(1, iGroup) = r
                vResult(2, iGroup) = Join(cr, ",")
            End If
        ElseIf iTemp + iNum < iSum Then
            Call MakeNumCount(vResult, ar, br, iGroup, iSum, bytDigit, iCount, iEleNum, iTemp + iNum, i + 1, iChkNum)
        End If
        br(i) = ""
     Next i
End Function

Function bSort(ar, iFirst&, iLast&, iLeft&, iRight&, _
    Optional iKey& = 1, Optional isOrder As Boolean = True)
    Dim i&, j&, k&, vTemp
   
    For i = iFirst To iLast - 1
        For j = iFirst To iLast + iFirst - 1 - i
            If ar(j, iKey) <> ar(j + 1, iKey) Then
                If ar(j, iKey) < ar(j + 1, iKey) Xor isOrder Then
                    For k = iLeft To iRight
                        vTemp = ar(j, k)
                        ar(j, k) = ar(j + 1, k)
                        ar(j + 1, k) = vTemp
                    Next
                End If
            End If
        Next j
    Next i
End Function
Function ShellSort2D(ByRef ar, ByVal iFirst&, ByVal iLast&, ByVal iLeft&, _
    ByVal iRight&, ByVal iKey&, Optional isOrder As Boolean = True)

    Dim iRowSize&, vTemp, interval&, i&, j&, k&

    ReDim vTemp(iLeft To iRight)
    iRowSize = iLast - iFirst + 1
    interval = 1

    If iRowSize > 13 Then
        Do While interval < iRowSize
            interval = interval * 3 + 1
        Loop
        interval = interval \ 9
    End If
   
    Do While interval
        For i = iFirst + interval To iLast
            For j = iLeft To iRight
                vTemp(j) = ar(i, j)
            Next
            If isOrder Then
                For k = i - interval To iFirst Step -interval
                    If ar(k, iKey) <= vTemp(iKey) Then Exit For
                    For j = iLeft To iRight
                         ar(k + interval, j) = ar(k, j)
                    Next j
                Next k
            Else
                For k = i - interval To iFirst Step -interval
                    If ar(k, iKey) > vTemp(iKey) Then Exit For
                    For j = iLeft To iRight
                        ar(k + interval, j) = ar(k, j)
                    Next j
                Next k
            End If
            For j = iLeft To iRight
                ar(k + interval, j) = vTemp(j)
            Next
        Next i
        interval = interval \ 3
    Loop

End Function

gwjkkkkk

组合的数据很多，确认要那么多。。。

micch

8个分别写，会写一个就会写8个了。写一个9个数的，基本删删就得到其他7个数的了

yynrzwh

香川递归版 E列任意n个数相加等于28.zip (20.61 KB, 下载次数: 11)

2024-6-17 00:05 上传

点击文件名下载附件

Dim a(), b(), h&, m&, n&
Sub test2() 'liulang0808 字典凑数 不用字典改成数组版 by kagawa 2018/08/14
    Dim i&, t&
   
    ActiveSheet.UsedRange.Offset(1, 6).ClearContents '清空输出区域
   
    m = [e1].End(4).Row - 1 '原始数据个数m
    a = WorksheetFunction.Transpose([e2].Resize(m)) '读取A2开始的原始数据
    ReDim b(m) '代替字典 记录凑数组合的数组b
   
    h = 28 '凑数目标和h
    n = 1 '输出起始行位置
   
    Call dg2(0, 0) '递归组合进行凑数
   
    MsgBox n '凑数组合结果总数n
End Sub
Sub dg2(r&, j&) '递归组合
    Dim i&, t&
    For i = j + 1 To m '遍历原始数据中剩余元素
        t = a(i): b(i) = t '数组b记录当前i位置加入组合的数t
        If r + t = h Then '累计相加正好相等时 为一组解
            n = n + 1 ': Cells(n, 3).Resize(, m) = b '输出解
            x = Application.Count(b)
            lr = Cells(Rows.Count, x + 5).End(3).Row
            If lr = 1 Then lr = 2 Else lr = lr + 2
            For y = 0 To m
                If Len(b(y)) > 0 Then
                    Cells(lr, x + 5) = Cells(y + 1, 1)
                    lr = lr + 1
                End If
            Next
        ElseIf r + t < h Then '不足时
            Call dg2(r + t, i) '继续递归凑数
        End If
        b(i) = "" '递归回溯时数组记录中清除当前i位置的数t
    Next
End Sub

LIUZHU

参与下，执行效果

LIUZHU

有些组合没有一个求和是28的

LIUZHU

JS代码

1. function 生成排列组合(){
   
2.         let obj=Range("a1").CurrentRegion.Value2.slice(1).reduce((obj,[a,,,,b])=>(obj[a]=b,obj),{})
   
3.         for (let i=2;i<=9;i++){
   
4.                 let arr=[[`${i}个相加结果等于28`]].concat(myplzh1(Object.keys(obj),"组合",i,obj));
   
5.                 Cells.Item(1,i+5).Resize(arr.length,1).Value2=arr;
   
6.         }
   
7. }
   
8. 
   
9. function myplzh1(szarr,type,n,obj){
   
10.         let arr=[],temp=new Array(n).fill(null);
    
11.         let h=0;                                        //h：统计递归所在的层数，不超过最底层(n-1)
    
12.         function getplzh(k){                //k：递归循环的起始位置
    
13.                 for (let i=k;i<szarr.length;i++){
    
14.                         if (temp.includes(szarr[i])) continue;                //统计不重复值
    
15.                         temp[h]=szarr[i];
    
16.                         if (temp[n-1]!=null){
    
17.                                 if (temp.reduce((a,b)=>a+obj[b],0)==28) arr.push(...(temp.map(x=>[x]).concat([[]])));
    
18.                         }
    
19.                         if (h<n-1){                                        //判断是否到达底层(n-1)，未达到则继续往下一层递归
    
20.                                 h++;                                        //层数递增
    
21.                                 getplzh(type=="组合"?i+1:0);                //递归,如果是组合，起始位置从i+1开始，否则从0开始
    
22.                         }
    
23.                 }
    
24.                 temp[h]=null;                //退出本层之前，将元素位置置空(null)
    
25.                 h--;                                //循环结束，退回到递归的上一层
    
26.         }
    
27.         getplzh(0);
    
28.         return arr;
    
29. }

复制代码

LIUZHU

附件，WPS测试有效，我只验证了三个组合，好像没错，其他的没有验证