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

Wei_1144 wrote:
如果數字可重複選取，例如 6 = 3 + 3，可解嗎？...(恕刪)

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

    Columns("E:Z").Clear

    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("C6") = "": Range("E1") = Format(Now(), "hh:mm:ss")

    If limited = 0 Then
        start = 1: 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)
        If start <> startend Then Range("C6") = Int((i / startend * 100) + 0.5) & "%請耐心等待"
    Next i
    
    '20190524 更新，無解時，find_name副程式會出錯(另一種方式沒問題)
    If ok <> 0 Then Call find_name '20190524 修正
    
    Range("C6") = "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 Single, item_name() As String, j As Integer, total As Long, k As Integer, n As Integer, ok As Integer, target As Single, limited As Integer, maxcombin As Integer, tolerance As Single)
    
    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
                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("C6") = "100%計算結束": Range("E2") = Format(Now(), "hh:mm:ss"): Debug.Print total
                    If ok <> 0 Then Call find_name '20190524 修正
                    End
                End If
            
                Range("c5") = ok
            
            End If

        Else
            Call findCombin(data, targetsum, item_name, j, total, i + 1, n + 1, ok, target, limited, maxcombin, tolerance)
        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
     
     lastrow = Range("g1").CurrentRegion.Rows.Count '20190524 修正
     For i = 1 To lastrow
        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 worte:
稍微更新一下，多加上...(恕刪)

heavenweaver worte:
如果我想找出總和的目標值是介於某個數值區間，例如：8000~10000，請問如何修改程式？在此先謝謝您！
真的很棒，如果能找某個數值區間總和的目標值之所有可能組合就更加完美了！...(恕刪)

kore5657 wrote:
如果我想要尋找加總為100的組合中，由8、10、12、14、16、18、20組合，且數字可重複的話(不限由多少個數字組成)，我該怎麼修改程式碼呢?

kore5657 wrote:
例如，我知道8在所有可能的組合中，最多只會有11個

snare wrote:
雖然很久很久以前在學(恕刪)