|
- Option Explicit
- Dim arrResult As Variant
- Sub Test()
- Dim arr As Variant, brr As Variant
- Dim dblVal As Double, dblOld As Double, blGet As Boolean
- arr = Sheet1.Range("B2:G2")
- ReDim brr(1 To 1, 1 To 6) As Long
- dblVal = Round(Sheet1.Range("B1").Value, 1)
- blGet = GetNum(arr, dblVal, brr, 1)
- If blGet Then
- MsgBox "找到最佳解法!"
- Else
- MsgBox "没有最佳解法,即将尝试进行接近值的解法!"
- Do While blGet = False
- dblVal = dblVal + 0.1
- ReDim brr(1 To 1, 1 To 6) As Long
- blGet = GetNum(arr, dblVal, brr, 1)
- Loop
- MsgBox "找到最接近的解法!"
- End If
- Sheet1.Range("B3").Resize(1, 6) = arrResult
- End Sub
- Function GetNum(arr As Variant, dblSum As Double, brr As Variant, lngColID As Long) As Boolean
- Dim dblTemp As Double, arrTemp As Variant
- Dim blOK As Boolean, lngID As Long
- arrTemp = brr
- arrTemp(1, lngColID) = arrTemp(1, lngColID) + 1
- dblTemp = Application.WorksheetFunction.SumProduct(arr, arrTemp)
- If dblTemp = dblSum Then
- arrResult = arrTemp
- GetNum = True
- Exit Function
- ElseIf dblTemp > dblSum Then
- arrTemp(1, lngColID) = arrTemp(1, lngColID) - 1
- lngColID = lngColID + 1
- If lngColID > UBound(arrTemp, 2) Then
- lngColID = 0
- For lngID = UBound(arrTemp, 2) - 1 To 1 Step -1
- If arrTemp(1, lngID) > 0 Then
- arrTemp(1, lngID) = arrTemp(1, lngID) - 1
- lngColID = lngID + 1
- Exit For
- End If
- Next
- If lngColID = 0 Then
- GetNum = False
- Exit Function
- End If
- End If
- End If
- blOK = blOK Or GetNum(arr, dblSum, arrTemp, lngColID)
- GetNum = blOK
- End Function
以上代码麻烦老师们帮忙修改一下,改成不需要按钮执行,谢谢!
|
|