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

nezher wrote:
比如100只有一個 那後面的排列不要再出現100

ren1244 wrote:
稍微看了一下程式
假設資料原本是 500, 400, 300, 200, 100
目標數值是 700
程式計算到 500 + 400 時
不會判斷數值已經超過了，會繼續往下測試 500 + 400 + 300 等數值
這會浪費很多計算時間
感覺可以優化加快速度

function findCombine(data, target) {
    data = data.sort((a, b) => b - a); //複製並排序
    let stack = [], stackIdx = 0; //堆疊
    let idx = 0; //目前應該讀取 data 的位置
    let sumVal = 0, val; //總和
    let result = []; //結果
    let testCount = 0; //計算共測試了幾個數字
    while (idx < data.length || stackIdx > 0) {
        //如果沒資料了則退回，找下一個
        if (idx >= data.length) {
            let topIdx = stack[--stackIdx];
            sumVal -= data[topIdx];
            idx = topIdx + 1;
            continue;
        }
        //加入 data[idx]
        stack[stackIdx++] = idx;
        sumVal += (val = data[idx++]);
        ++testCount;
        //若符合則記錄，超過則退回
        if (sumVal === target) {
            let tmp = [];
            for (let i = 0; i < stackIdx; ++i) {
                tmp.push(data[stack[i]]);
            }
            result.push(tmp);
        } else if (sumVal > target) {
            --stackIdx;
            sumVal -= val;
        }
    }
    return {result, testCount};
}

ren1244 wrote:
所以用 html + javascript 做個範例
如下圖，第一組(20個數字)只要測試 624457 個組合就夠了

'(不可重複選取的不重複組合公式)
'簡單修改後程式碼，有點亂，修修補補的，不想整理了


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

    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)
    data(1, 1) = Cells(2, 2).Value
    
    For d = 1 To lastrow - 1
        data(1, d) = Cells(d + 1, 2).Value
    Next d
       
    For d = 1 To UBound(data, 2) - 1
        For e = d + 1 To UBound(data, 2)
            If data(1, d) > data(1, e) Then
                temp = data(1, d)
                data(1, d) = data(1, e)
                data(1, e) = temp
            End If
        Next e
    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
            For d = 1 To UBound(data, 2)
                f = f + data(1, d)
                If f > target Then Exit For
            Next d
            startend = d - 1
        End If
    Else
        start = limited: startend = start
    End If

    For i = start To startend
        ReDim targetsum(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
        If n = j Then
            
            total = total + 1

            For s = 1 To UBound(targetsum)
                tempsum = tempsum + targetsum(s)
                If tempsum > target Then Exit Sub
            Next s

            If tempsum = target Then
                ok = ok + 1
                Range("G" & ok).Resize(1, j) = targetsum
                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
                
                Exit Sub
            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

For i = start To startend
    ReDim targetsum(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

function findCombine(data, target, minItem, maxItem, oneSolution) {
    data = data.sort((a, b) => b - a); //複製並排序
    let stack = [], stackIdx = 0; //堆疊
    let idx = 0; //目前應該讀取 data 的位置
    let sumVal = 0, val; //總和
    let result = []; //結果
    let testCount = 0; //計算共測試了幾個數字
    while (idx < data.length || stackIdx > 0) {
        //如果沒資料或超過允許選取個數，則退回，找下一個
        if (idx >= data.length || stackIdx>=maxItem) {
            let topIdx = stack[--stackIdx];
            sumVal -= data[topIdx];
            idx = topIdx + 1;
            continue;
        }
        //加入 data[idx]
        stack[stackIdx++] = idx;
        sumVal += (val = data[idx++]);
        ++testCount;
        //若符合則記錄，超過則退回
        if (sumVal === target) {
            if(stackIdx >= minItem) {
                let tmp = [];
                for (let i = 0; i < stackIdx; ++i) {
                    tmp.push(data[stack[i]]);
                }
                result.push(tmp);
                //如果只需要1解，有1解就終止
                if(oneSolution && result.length>0) {
                    break;
                }
            } else {
                --stackIdx;
                sumVal -= val;
            }
        } else if (sumVal > target) {
            --stackIdx;
            sumVal -= val;
        }
    }
    return {result, testCount};
}

ren1244 wrote:
下面這段我覺得還可以優化啦
For i = start To startend
ReDim targetsum(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

舉例來說 i = 3 時，呼叫 findCombin 也是從 i = 1, 2... 開始產生組合
所以前面的 i 會重複很多次

Sub TestSpeed()
    Dim i As Long
    Dim j As Long
    Dim t As Long
    t = GetSystemTicks()
    For i = 1 To 624457
        j = j + 1
    Next i
    MsgBox "執行" & (GetSystemTicks() - t) & "毫秒"
End Sub

Type DataType
    Val As Double '數值
    Lab As String '標籤
End Type

Sub Main
    ' 目前開啟的頁面
    Dim sheet As Object
    sheet = ThisComponent.CurrentController.ActiveSheet
    
    ' 清除舊資料
    sheet.getCellRangeByPosition(5, 0, sheet.getColumns().Count - 1, sheet.getRows().Count - 1).clearContents(1023)
    
    ' 讀取資料到陣列
    Dim lastIndex As Long
    lastIndex = getEndOfColumn(sheet, 1) ' 資料在 1~lastIndex 列
    Dim data(lastIndex - 1) As DataType
    For iRow=1 To lastIndex
        data(iRow - 1).Val = sheet.getCellByPosition(1, iRow).Value
        data(iRow - 1).Lab = sheet.getCellByPosition(0, iRow).String
    Next iRow
    
    ' 排序
    QuickSort(data, 0, lastIndex - 1)
    
    ' 讀取設定
    Dim target As Double, minItem As Long, maxItem As Long, oneSol As Long
    target = readAsValue(sheet, 3, 1, -1)
    minItem = readAsValue(sheet, 3, 2, 1)
    maxItem = readAsValue(sheet, 3, 3, lastIndex)
    oneSol = readAsValue(sheet, 3, 4, 0)
    
    ' 尋找組合
    Dim t0 As Long, t1 As Long, t2 As Long, CombinResult As Variant
    Dim nCombins As Long, nSolutions As Long, resultArr As Variant, maxLen As Long
    Dim outputData() As Variant, maxIdx As Long, str As String
    t0 = GetSystemTicks()
    If target > 0 Then
        CombinResult = findTheCombin(data, lastIndex, target, minItem, maxItem, oneSol)
        t1 = GetSystemTicks()
        nCombins = CombinResult(0)
        nSolutions = CombinResult(1)
        resultArr = CombinResult(2)
        maxLen = CombinResult(3)
        Redim outputData(nSolutions - 1, maxLen)
        For i = 0 To nSolutions - 1
            maxIdx = UBound(resultArr(i))
            str = ""
            For j = 0 To maxLen
                If j > maxIdx + 1 Then
                    outputData(i, j) = ""
                ElseIf j > 0 Then
                    outputData(i, j) = data(resultArr(i)(j - 1)).Val
                    If j = 1 Then
                        str = data(resultArr(i)(j - 1)).Lab
                    Else
                        str = str & ", " & data(resultArr(i)(j - 1)).Lab
                    End If
                Else
                    outputData(i, j) = ""
                End If
            Next j
            outputData(i, 0) = str
        Next i
        sheet.getCellRangeByPosition(5, 1, 5 + maxLen, nSolutions).DataArray =  outputData
        t2 = GetSystemTicks()
        sheet.getCellByPosition(5, 0).String = "共測試 " & nCombins & " 個組合, 得到 " & nSolutions & " 個解, 花費計算 " & (t1-t0) & " 毫秒, 寫入 " & (t2-t1) & " 毫秒"
    End If
End Sub

Function findTheCombin(data() AS DataType, n As Long, target As Double, minItem As Long, maxItem As Long, oneSol As Long)
    '紀錄使用 data index 的堆疊
    Dim stack(n) As Long, stackIdx As Long, sumVal(n) as Double
    sumVal(0) = 0
    stackIdx = 1
    '目前應該讀取 data 的位置
    Dim idx As Long
    idx = 0
    '計算共測試了幾個組合
    Dim testCount As Long
    testCount = 0
    '輸出使用
    Dim result() As Variant, resultIdx As Long, resultSize As Long, resultTemp() As Long, maxLen As Long
    resultSize = 4
    resultIdx = 0
    maxLen = 0
    Redim result(resultSize - 1)
    '其他暫存變數
    Dim k As Long

    Do While idx < n Or stackIdx > 1
        '如果沒資料或超過允許選取個數，則退回，找下一個
        If idx >= n Or stackIdx > maxItem Then
            stackIdx = stackIdx - 1
            idx = stack(stackIdx) + 1
        Else
            '加入 data[idx]
            stack(stackIdx) = idx
            sumVal(stackIdx) = sumVal(stackIdx - 1) + data(idx).Val
            stackIdx = stackIdx + 1
            idx = idx + 1
            testCount = testCount + 1
            ' 若符合則記錄，超過則退回
            If sumVal(stackIdx - 1) = target Then
                If stackIdx > minItem Then
                    ' 紀錄
                    Redim resultTemp(stackIdx - 2)
                    If maxLen < stackIdx - 1 Then
                        maxLen = stackIdx - 1
                    End If
                    For k = 1 To stackIdx - 1
                        resultTemp(k - 1) = stack(k)
                    Next k
                    If resultIdx >= resultSize Then
                        resultSize = resultSize * 2
                        Redim Preserve result(resultSize - 1)
                    End If
                    result(resultIdx) = resultTemp
                    resultIdx = resultIdx + 1
                    ' 如果只需要1解，有1解就終止
                    If oneSol > 0 Then
                        Exit Do
                    End If
                Else
                    stackIdx = stackIdx - 1
                End If
            ElseIf sumVal(stackIdx - 1) > target Then
                stackIdx = stackIdx - 1
            End If
        End If
    Loop
    findTheCombin = Array(testCount, resultIdx, result, maxLen)
End Function

' 取得某行最後一筆資料的索引
Function getEndOfColumn(sheet As Object, colIndex As Long)
    Dim n As Long, tp As Long
    n = 0
    Do
        n = n + 1
        tp = sheet.getCellByPosition(colIndex, n).getType()
    Loop While tp <>  com.sun.star.table.CellContentType.EMPTY
    getEndOfColumn = n - 1
End Function

' 排序
Sub QuickSort(vArray As DataType, inLow As Long, inHi As Long)
    Dim pivot   As DataType
    Dim tmpSwap As DataType
    Dim tmpLow  As Long
    Dim tmpHi   As Long

    tmpLow = inLow
    tmpHi = inHi

    pivot.Val = vArray((inLow + inHi) \ 2).Val
    pivot.Lab = vArray((inLow + inHi) \ 2).Lab


    While (tmpLow <= tmpHi)
        While (vArray(tmpLow).Val > pivot.Val And tmpLow < inHi)
            tmpLow = tmpLow + 1
        Wend

        While (pivot.Val > vArray(tmpHi).Val And tmpHi > inLow)
            tmpHi = tmpHi - 1
        Wend

        If (tmpLow <= tmpHi) Then
            tmpSwap.Val = vArray(tmpLow).Val
            tmpSwap.Lab = vArray(tmpLow).Lab
            vArray(tmpLow).Val = vArray(tmpHi).Val
            vArray(tmpLow).Lab = vArray(tmpHi).Lab
            vArray(tmpHi).Val = tmpSwap.Val
            vArray(tmpHi).Lab = tmpSwap.Lab
            tmpLow = tmpLow + 1
            tmpHi = tmpHi - 1
        End If
    Wend

    If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
    If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Function readAsValue(sheet As Object, iCol As Long, iRow As Long, defaultVal As Long)
    Dim cell As Object
    cell = sheet.getCellByPosition(iCol, iRow)
    if cell.getType() = com.sun.star.table.CellContentType.VALUE Then
        readAsValue = cell.Value
    Else
        readAsValue = defaultVal
    End If
End Function

Sub TestSpeed()
    Dim i As Long
    Dim j As Long
    Dim t As Long
    t = GetSystemTicks()
    For i = 1 To 624457
        j = j + 1
    Next i
    MsgBox "執行" & (GetSystemTicks() - t) & "毫秒"
End Sub

ren1244 wrote:
以 23 組數據的那個例子
basic：共測試 338707 個組合, 得到 180 個解, 花費計算 6731 毫秒, 寫入 45 毫秒
python：共測試 338707 個組合, 得到 180 個解, 花費計算 125 毫秒, 寫入 16 毫秒

發現兩者速度差滿多的

basic 慢不是算法的問題
因為 Libre Office 的 basic 連以下這樣的程式都要執行 919 毫秒

ren1244 wrote:
而 MS Office 跟 Libre Office 執行 Basic 的速度也是有差異

Sub Main()
    
 '此範例、高速演算法是 mobile01 ren1244 高手作品
 '我只有簡單改寫LibreOffice vb to Excel VBA，修正少數幾行程式碼相容性問題
    
    
 ' 清除舊資料
    Columns("E:Z").Clear
    
    ' 讀取資料到陣列
    Dim lastIndex As Long, data(), ttt As Double
    lastIndex = Range("A2").End(xlDown).Row - 1
    ReDim data(1, lastIndex - 1)
    
    For iRow = 1 To lastIndex
        
        data(0, iRow - 1) = Cells(iRow + 1, 2).Value
        data(1, iRow - 1) = Cells(iRow + 1, 1).Value

    Next iRow
    
    ' 排序
    
    
    For d = 0 To UBound(data, 2) - 1
        For e = d + 1 To UBound(data, 2)
            If data(0, d) < data(0, e) Then
                temp0 = data(0, d)
                temp1 = data(1, d)
                data(0, d) = data(0, e)
                data(1, d) = data(1, e)
                data(0, e) = temp0
                data(1, e) = temp1
            End If
        Next e
    Next d
    
    
    ttt = Timer
    
    
    ' 讀取設定
    Dim target As Double, minItem As Long, maxItem As Long, oneSol As Long
    target = Range("d2")
    minItem = IIf(Range("d3") = "", 1, Range("d3"))
    maxItem = IIf(Range("d4") = "", lastIndex, Range("d4"))
    oneSol = IIf(Range("d5") = "", 0, Range("d5"))
    
    ' 尋找組合
    Dim t0 As Long, t1 As Long, t2 As Long, CombinResult As Variant
    Dim nCombins As Long, nSolutions As Long, resultArr As Variant, maxLen As Long
    Dim outputData() As Variant, maxIdx As Long, str As String
    
    If target > 0 Then
        CombinResult = findTheCombin(data, lastIndex, target, minItem, maxItem, oneSol)
        
        nCombins = CombinResult(0)
        nSolutions = CombinResult(1)
        resultArr = CombinResult(2)
        maxLen = CombinResult(3)
        ReDim outputData(nSolutions - 1, maxLen)
        For i = 0 To nSolutions - 1
            maxIdx = UBound(resultArr(i))
            str = ""
            For j = 0 To maxLen
                If j > maxIdx + 1 Then
                    outputData(i, j) = ""
                ElseIf j > 0 Then
                    outputData(i, j) = data(0, resultArr(i)(j - 1))
                    If j = 1 Then
                        str = data(1, resultArr(i)(j - 1))
                    Else
                        str = str & ", " & data(1, resultArr(i)(j - 1))
                    End If
                Else
                    outputData(i, j) = ""
                End If
            Next j
            outputData(i, 0) = str
        Next i
        
        Range("f2").Resize(nSolutions, maxLen) = outputData
        Range("f1") = "共測試 " & nCombins & " 個組合, 得到 " & nSolutions & " 個解, 花費計算 " & Timer - ttt & " 秒"
        
    End If
    
End Sub

Function findTheCombin(data(), n As Long, target As Double, minItem As Long, maxItem As Long, oneSol As Long)
    '紀錄使用 data index 的堆疊
    Dim stack(), stackIdx As Long, sumVal()
    ReDim stack(n)
    ReDim sumVal(n)
    sumVal(0) = 0
    stackIdx = 1
    '目前應該讀取 data 的位置
    Dim idx As Long
    idx = 0
    '計算共測試了幾個組合
    Dim testCount As Long
    testCount = 0
    '輸出使用
    Dim result() As Variant, resultIdx As Long, resultSize As Long, resultTemp() As Long, maxLen As Long
    resultSize = 4
    resultIdx = 0
    maxLen = 0
    ReDim result(resultSize - 1)
    '其他暫存變數
    Dim k As Long

    Do While idx < n Or stackIdx > 1
        '如果沒資料或超過允許選取個數，則退回，找下一個
        If idx >= n Or stackIdx > maxItem Then
            stackIdx = stackIdx - 1
            idx = stack(stackIdx) + 1
        Else
            '加入 data[idx]
            stack(stackIdx) = idx
            sumVal(stackIdx) = sumVal(stackIdx - 1) + data(0, idx)
            stackIdx = stackIdx + 1
            idx = idx + 1
            testCount = testCount + 1
            ' 若符合則記錄，超過則退回
            If sumVal(stackIdx - 1) = target Then
                If stackIdx > minItem Then
                    ' 紀錄
                    ReDim resultTemp(stackIdx - 2)
                    If maxLen < stackIdx - 1 Then
                        maxLen = stackIdx - 1
                    End If
                    For k = 1 To stackIdx - 1
                        resultTemp(k - 1) = stack(k)
                    Next k
                    If resultIdx >= resultSize Then
                        resultSize = resultSize * 2
                        ReDim Preserve result(resultSize - 1)
                    End If
                    result(resultIdx) = resultTemp
                    resultIdx = resultIdx + 1
                    ' 如果只需要1解，有1解就終止
                    If oneSol > 0 Then
                        Exit Do
                    End If
                Else
                    stackIdx = stackIdx - 1
                End If
            ElseIf sumVal(stackIdx - 1) > target Then
                stackIdx = stackIdx - 1
            End If
        End If
    Loop
    findTheCombin = Array(testCount, resultIdx, result, maxLen)
End Function