返回列表 上一主題 發帖

[發問] 數值排列組合問題

[發問] 數值排列組合問題

請問各位排列組合問題
我想要做各種數值的組合後,判定所得結果.但是我還是想不出怎麼解.
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

T1.rar (5.02 KB)

排列組合

回復 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. Sub backtrack(ByRef arInput, ByRef flagTake, n As Integer, cost As Double, ByRef dResult As Object)
  15.     Dim i As Integer, strOut As String
  16.    
  17.     If cost > 0 And cost <= 105 Then
  18.         For i = LBound(arInput, 2) To UBound(arInput, 2)
  19.             If Len(strOut) = 0 Then
  20.                 strOut = IIf(flagTake(i), arInput(1, i), "")
  21.             Else
  22.                 strOut = strOut & IIf(flagTake(i), "+" & arInput(1, i), "")
  23.             End If
  24.         Next
  25.         dResult.Add strOut, cost    'push to result
  26.     End If
  27.    
  28.     For i = n To UBound(arInput, 2)
  29.         flagTake(i) = True
  30.         backtrack arInput, flagTake, i + 1, cost + arInput(2, i), dResult
  31.         flagTake(i) = False   '回復flag
  32.     Next
  33. End Sub
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

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

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

TOP

本帖最後由 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

TOP

謝謝各位的幫忙!感謝!

TOP

        靜思自在 : 天上最美是星星,人生最美是溫情。
返回列表 上一主題