標題: [發問] 數值排列組合問題 [打印本頁]

---

作者: qmi    時間: 2016-3-18 00:02     標題: 數值排列組合問題

請問各位排列組合問題
我想要做各種數值的組合後,判定所得結果.但是我還是想不出怎麼解.
A＝$100
B＝$50
C＝$25
D＝$5

例如:小明身上只有＄105,想要買到上面A∼D(或者A~n種)餐點,每種都不能重複,可以買到哪些組合?
A=100-->O
AB=150-->X
ABC=175-->X
ABCD=180-->X
AC=125-->X
ACD=130-->X
AD=105-->O
B=50-->O
BC=75-->O
BCD=80-->O
BD=55-->O
C=25-->O
CD=30-->O
D=5-->O

Sub T1()
Range("E:F").Clear
MyC = 4
r = 3
AddX = 1
T = ""
m = 0
For i = 1 To MyC
    For j = i To MyC
        r = r + 1
        If T = "" Then
            T = Cells(1, j)
            m = m + Cells(2, j)
        Else
            T = T & "+" & Cells(1, j)
            m = m + Cells(2, j)
        End If
        Cells(r, 5) = T
        Cells(r, 6) = m
    Next j
    T = ""
    m = 0
Next i
End Sub

---

作者: stillfish00    時間: 2016-3-18 14:25

回復 1# qmi

1. Sub Test()
   
2.     Dim arInput, flagTake
   
3.     Dim dResult As Object: Set dResult = CreateObject("scripting.dictionary")
   
4.    
   
5.     arInput = Range("A1").CurrentRegion.Value
   
6.     ReDim flagTake(LBound(arInput, 2) To UBound(arInput, 2)) As Boolean 'true=取 ; false=不取
   
7.    
   
8.     backtrack arInput, flagTake, 1, 0, dResult
   
9.    
   
10.     Range("E:F").ClearContents
    
11.     Range("E4").Resize(dResult.count).Value = Application.Transpose(dResult.keys)
    
12.     Range("F4").Resize(dResult.count).Value = Application.Transpose(dResult.items)
    
13. End Sub
    
14. 
    
15. Sub backtrack(ByRef arInput, ByRef flagTake, n As Integer, cost As Double, ByRef dResult As Object)
    
16.     Dim i As Integer, strOut As String
    
17.    
    
18.     If cost > 0 And cost <= 105 Then
    
19.         For i = LBound(arInput, 2) To UBound(arInput, 2)
    
20.             If Len(strOut) = 0 Then
    
21.                 strOut = IIf(flagTake(i), arInput(1, i), "")
    
22.             Else
    
23.                 strOut = strOut & IIf(flagTake(i), "+" & arInput(1, i), "")
    
24.             End If
    
25.         Next
    
26.         dResult.Add strOut, cost    'push to result
    
27.     End If
    
28.    
    
29.     For i = n To UBound(arInput, 2)
    
30.         flagTake(i) = True
    
31.         backtrack arInput, flagTake, i + 1, cost + arInput(2, i), dResult
    
32.         flagTake(i) = False   '回復flag
    
33.     Next
    
34. End Sub

複製代碼

---

作者: jackyq    時間: 2016-3-18 17:01

' 大大可以用這個枚舉索引

Function GG1(id_ar, ByVal id_ar_value_max As Long) As Boolean
     Dim ub&, w&, k&
     
         ub = UBound(id_ar)
      id_ar(ub) = id_ar(ub) + 1
   If id_ar(ub) > id_ar_value_max Then
      
      For w = ub - 1 To LBound(id_ar) Step -1
          If (id_ar(w) + UBound(id_ar) - w) < id_ar_value_max Then
             id_ar(w) = id_ar(w) + 1
             For k = w + 1 To ub
                 id_ar(k) = id_ar(k - 1) + 1
             Next
             GG1 = True
             Exit Function
          End If
      Next
    Else
      GG1 = True
    End If
End Function

---

作者: jackyq    時間: 2016-3-18 17:36

本帖最後由 jackyq 於 2016-3-18 17:37 編輯

Sub 執行我()

  欄位_Max = Cells(, "D").Column
  
  For cc = 1 To 欄位_Max
    ReDim 欄位(1 To cc) As Long
    ReDim Result(1 To cc) As String
    For w = 1 To cc: 欄位(w) = w: Next
   
    Do
      money= 0
      For w = LBound(欄位) To UBound(欄位)
          money = money + val(Cells(2, 欄位(w)))
          If money > 105 Then Exit For
          Result(w) = Cells(1, 欄位(w))
      Next
      If money <= 105 Then
         Result_s = Result_s & Join(Result, "+") & " = " & money & vbCrLf
      End If
    Loop Until Not GG1(id_ar:=欄位, id_ar_value_max:=欄位_Max)
  Next
   
  If Result_s <> "" Then MsgBox Result_s
End Sub

---

作者: qmi    時間: 2016-3-19 00:07

謝謝各位的幫忙！感謝！

---

歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)