(6/28 小更新)Excel多組數字挑選加總為指定數值的方法(vba 範例)

kore5657 wrote:
不好意思...我忘了還有一個很重要的條件
我的問題中並不用考慮組合的順序...
例如：
100 = 8+8+8+8+8+8+8+8+8+8+10+10
不管組合內的數字怎麼替換順序，都只算一種

Sub test()
    
    Dim data(), targetsum() As Double, item_name() As String, lastrow As Integer, ttt As Double
    Dim total As Long, i As Integer, ok As Integer, target As Double, limited As Integer, maxcombin As Integer, start As Integer, startend As Integer, tolerance As Double, rs As Boolean

    Columns("E:Z").Clear

'esc中斷功能，計算極大量資料時無效，程式會來不及回應
    On Error GoTo Esc_Stop
    Application.EnableCancelKey = xlErrorHandler

    ttt = Timer

    lastrow = Range("A2").End(xlDown).Row
    ReDim data(1 To 2, 1 To lastrow - 1)
    
    For d = 1 To lastrow - 1
        data(1, d) = Cells(d + 1, 2).Value
    '    data(2, d) = Cells(d + 1, 1).Value
    Next d
    
    If Range("C1") = 0 Then End

    target = Range("C1"):  tolerance = Range("C2"): limited = Range("C3"): maxcombin = Range("C4")
    Range("C5") = "": Range("C8") = "": Range("E1") = Format(Now(), "hh:mm:ss")
    
    If Range("c6") = "" Then
        Range("c6") = False
        Range("c7") = ""
    End If
    
    If Range("c6") = True And Range("c7") = "" Then Range("c7") = 15
    
    rs = Range("c6")

    If limited = 0 Then
        start = 1
        If rs = True Then startend = Range("c7") Else startend = UBound(data, 2)
    Else
        start = limited: startend = start
    End If

    For i = start To startend
        ReDim targetsum(1 To i)
   '     ReDim item_name(1 To i)
        Call findCombin(data, targetsum, item_name, i, total, 1, 1, ok, target, limited, maxcombin, tolerance, rs)
        If start <> startend Then Range("C8") = Int((i / startend * 100) + 0.5) & "%請耐心等待"
    Next i
    
    If ok <> 0 Then Call find_name
    
    Range("C8") = "100%計算結束": Range("E2") = Format(Now(), "hh:mm:ss")
    Debug.Print total, Timer - ttt
    
    Exit Sub
    
Esc_Stop:
    If Err = 18 Then
        MsgBox "stop"
    End If

End Sub

Sub findCombin(data(), targetsum() As Double, item_name() As String, j As Integer, total As Long, k As Integer, n As Integer, ok As Integer, target As Double, limited As Integer, maxcombin As Integer, tolerance As Double, rs As Boolean)
    
    Dim i As Integer, tempsum As Double
    
    For i = k To UBound(data, 2)

        targetsum(n) = data(1, i): tempsum = 0
       ' item_name(n) = data(2, i)
    
        If n = j Then
            total = total + 1
        
            For s = 1 To UBound(targetsum)
                tempsum = tempsum + targetsum(s)
            Next s

            If tempsum = target Then '把變數tolerance代入這一行，就可增加誤差值功能
                ok = ok + 1
                
                Range("G" & ok).Resize(1, j) = targetsum
       '         Range("F" & ok) = Join(item_name, ",")
      
                If (ok = maxcombin And maxcombin <> 0) Then
                    Range("C5") = ok: Range("C8") = "100%計算結束": Range("E2") = Format(Now(), "hh:mm:ss"): Debug.Print total
                    If ok <> 0 Then Call find_name
                    End
                End If
            
                Range("c5") = ok
            
            End If

        Else
            Call findCombin(data, targetsum, item_name, j, total, i + IIf(rs, 0, 1), n + 1, ok, target, limited, maxcombin, tolerance, rs)
        End If
    
    Next i
    
End Sub

Sub find_name()
     
     Dim lastrow As Integer, lastcol As Integer, n As Object, name_data() As String
     Set n = CreateObject("Scripting.Dictionary")
     Application.ScreenUpdating = False
     
     lastrow = Range("A1").End(xlDown).Row
     For i = 2 To lastrow
         n.Add Str(Cells(i, 2)), Cells(i, 1)
     Next i
     
     
     For i = 1 To Range("c5").Value
        lastcol = Range("G" & i).End(xlToRight).Column
        ReDim name_data(1 To lastcol - 6)
        
        For j = 7 To lastcol
            name_data(j - 6) = n(Str(Cells(i, j)))
        Next j
        
        Cells(i, 6) = Join(name_data, ",")
        
     Next i
    
     Set n = Nothing
     Application.ScreenUpdating = True
     
End Sub

snare wrote:
這是可重複選取的不重(恕刪)

snare wrote:
(***此文只在mobile01...(恕刪)

GordonYiu wrote:
看了一下樓主最新的11樓，就已經更新成可以接受小數了，你可以下載第11樓的excel 檔。(恕刪)

pretty_woman wrote:
另暫時只有38個數值需要運算，但程式都在16%時沒有回應了。

pretty_woman wrote:
剛我在做測試，用不可重複選取的模式，跑了35分鐘至34%就不再運行了，請問大大還有其他方法比較適合較多編號的數據嗎？

GordonYiu wrote:
這還真是有趣，雖然是一個小小的程式，先不要那麼早放棄。樓主有沒有考慮到long資料型態的問題呢？long 只能支援到– 2,147,483,648 and 2,147,483,647，大概是10位數。

GordonYiu wrote:
2^38-1=274,877,906,943有12位數，會不會是這問題呢？另外還有沒有其他的演算法呢？只能這樣硬碰硬嗎？只能把這麼多組合都算出來再比對嗎？

snare wrote:
稍微更新一下，多加上(恕刪)

nezher wrote:
請問假設100只設定了一項
為什麼後續的組合100卻會被重複使用

nezher wrote:
能不能讓被組合過的數字在不同組也不再使用?

snare wrote:
看不太懂您的發問?排(恕刪)