# 求助！穷举！

hainanzlt99 2021-05-06 03:20:08

...全文
3898 30 打赏 收藏 转发到动态 举报

30 条回复

milaoshu1020 2021-05-10
• 打赏
• 举报

``````
Option Explicit

Private Sub cmdStartCombine_Click()
TextI = ""
TextJ = ""
TextK = ""
TextResult = ""

Dim a As Long
a = TextA

Dim b As Long
b = TextB

Dim c As Long
c = TextC

Dim d As Long
d = TextD

Dim datStartTime As Date
datStartTime = Now

' 这三个是条件判断,根据三个公式变换而来,不符合任何一项都没有结果;
If d * a < 93 And d * b < 930 And d * c < 9000 Then
Dim i As Long
For i = 0 To 9999
' 计算剩余时间;
Dim datNowTime As Date
datNowTime = Now

Dim lngSecondUsed As Long
lngSecondUsed = DateDiff("s", datStartTime, datNowTime)

Dim lngSecondTotal As Long
lngSecondTotal = lngSecondUsed * 10001 \ (i + 1)

Dim lngSecondRemain As Long
lngSecondRemain = lngSecondTotal - lngSecondUsed

Dim intHours As Integer
intHours = lngSecondRemain \ 3600

Dim intMinutes As Integer
intMinutes = lngSecondRemain \ 60 Mod 60

Dim intSeconds As Integer
intSeconds = lngSecondRemain Mod 60

TextResult = i & " 剩余时间: " & intHours & ":" & intMinutes & ":" & intSeconds

Dim lngLastSecondUsed As Long
If lngSecondUsed > lngLastSecondUsed Then
lngLastSecondUsed = lngSecondUsed

' 判断是否界面已退出;
If Not Me.Visible Then
MsgBox "计算中断!"
Exit Sub
End If

DoEvents
End If

' 在i已确定,设k=0的情况下,用前两个公式计算j的范围;
Dim jmax As Long
jmax = (93 - d * a) * i / (d * b) ' 公式1忽略k,变形

Dim jmin As Long
jmin = d * a * i / (930 - d * b) ' 公式2忽略k,变形

Dim j As Long
For j = IIf(jmin < 0, 0, jmin) To IIf(jmax > 9999, 9999, jmax)
' 在i,j已经确定的情况下,用三个公式确定k值的范围;
Dim kmax1 As Long ' 公式1变形
kmax1 = (93 * i - d * a * i - d * b * j) / (d * c)

Dim kmax2 As Long ' 公式2变形
kmax2 = (930 * j - d * a * i - d * b * j) / (d * c)

Dim kmax As Long
kmax = IIf(kmax1 < kmax2, kmax1, kmax2)

Dim kmin As Long ' 公式3变形
kmin = (d * a * i + d * b * j) / (9000 - d * c)

Dim k As Long
For k = IIf(kmin < 0, 0, kmin) To IIf(kmax > 9999, 9999, kmax)
Dim temp As Long
temp = d * (a * i + b * j + c * k)

If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
TextI = i
TextJ = j
TextK = k
TextResult = "组合完成."
Exit Sub
End If
Next
Next

Next
End If

TextResult = "没有这种组合!"

End Sub
``````

• 打赏
• 举报

milaoshu1020 2021-05-09
• 打赏
• 举报

``````Option Explicit

Private Sub cmdStartCombine_Click()
TextI = ""
TextJ = ""
TextK = ""
TextResult = ""

Dim a As Long
a = TextA

Dim b As Long
b = TextB

Dim c As Long
c = TextC

Dim d As Long
d = TextD

Dim datStartTime As Date
datStartTime = Now

' 这三个是条件判断,根据三个公式变换而来,不符合任何一项都没有结果;
If d * a < 93 And d * b < 930 And d * c < 9000 Then
Dim i As Long
For i = 0 To 10000
DoEvents

' 在i已确定,设k=0的情况下,用前两个公式计算j的范围;
Dim jmax As Long
jmax = (93 - d * a) * i / (d * b) ' 公式1忽略k,变形

Dim jmin As Long
jmin = d * a * i / (930 - d * b) ' 公式2忽略k,变形

Dim j As Long
For j = jmin To jmax
' 在i,j已经确定的情况下,用三个公式确定k值的范围;
Dim kmax1 As Long ' 公式1变形
kmax1 = (93 * i - d * a * i - d * b * j) / (d * c)

Dim kmax2 As Long ' 公式2变形
kmax2 = (930 * j - d * a * i - d * b * j) / (d * c)

Dim kmax As Long
kmax = IIf(kmax1 < kmax2, kmax1, kmax2)

Dim kmin As Long ' 公式3变形
kmin = (d * a * i + d * b * j) / (9000 - d * c)

Dim k As Long
For k = kmin To kmax
Dim temp As Long
temp = d * (a * i + b * j + c * k)

If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
TextI = i
TextJ = j
TextK = k
TextResult = "组合完成."
Exit Sub
End If
Next
Next

Dim datNowTime As Date
datNowTime = Now

Dim lngSecondUsed As Long
lngSecondUsed = DateDiff("s", datStartTime, datNowTime)

Dim lngSecondTotal As Long
lngSecondTotal = lngSecondUsed * 10001 \ (i + 1)

Dim lngSecondRemain As Long
lngSecondRemain = lngSecondTotal - lngSecondUsed

Dim intHours As Integer
intHours = lngSecondRemain \ 3600

Dim intMinutes As Integer
intMinutes = lngSecondRemain \ 60 Mod 60

Dim intSeconds As Integer
intSeconds = lngSecondRemain Mod 60

TextResult = i & " 剩余时间: " & intHours & ":" & intMinutes & ":" & intSeconds

If Not Me.Visible Then
MsgBox "计算中断!"
Exit Sub
End If
Next
End If

TextResult = "没有这种组合!"

End Sub
``````

milaoshu1020 2021-05-09
• 打赏
• 举报

sonic_andy 2021-05-09
• 打赏
• 举报

hainanzlt99 2021-05-08
• 打赏
• 举报

[quote=引用 17 楼 hainanzlt99 的回复:]速度好慢，每次运行都要2个小时！

milaoshu1020 2021-05-08
• 打赏
• 举报

• 打赏
• 举报

milaoshu1020 2021-05-08
• 打赏
• 举报

``````Option Explicit

Private Sub cmdStartCombine_Click()
TextI = ""
TextJ = ""
TextK = ""
TextResult = ""

Dim a As Long
a = TextA

Dim b As Long
b = TextB

Dim c As Long
c = TextC

Dim d As Long
d = TextD

Dim i As Long
For i = 1 To 9999
DoEvents

Dim j As Long
For j = 1 To 9999
Dim k As Long
' 为什么k从1到1,因为画截面图可以看出,如果k>1成立的话,k=1也必定成立,因为f(k)=9000*k
' 这个平面已经基本上立起来了,与k轴连成的棱锥体已经覆盖了指定范围内所有的i,j整数点,
' 那么k就没有必要循环那么多次了;
For k = 1 To 1
Dim temp As Long
temp = d * (a * i + b * j + c * k)

If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
TextI = i
TextJ = j
TextK = k
TextResult = "组合完成."
Exit Sub
End If
Next
Next
Next

TextResult = "没有这种组合!"

End Sub
``````

• 打赏
• 举报

……………………

“穷举”并不是一定要无条件的把所有组合都要“尝试一下”，

也照样是属于“穷举”的范畴。

就能实现“很短的时间”就排查完毕了。

• 打赏
• 举报

[quote=引用 18 楼 脆皮大雪糕 的回复:][quote=引用 17 楼 hainanzlt99 的回复:]速度好慢，每次运行都要2个小时！

15楼代码没效！输入a27 b81 c54 d=2没结果。正常i=7 j=1 k=1能通过！[/quote]

a=27， b=81， c=54， d=2

a=40， b=42， c=205， d=2

（唯一结果：90，9，1）

a=1， b=1， c=5000， d=2
（当然这只是一组简单的例子，类似的组合多得很）

• 打赏
• 举报

因此在“开始组合”前一定要把a、b、c、d这四个参数输入合法数值！

``````Option Explicit

Private Declare Function GetTickCount Lib "Kernel32" () As Long

Private Type ResultList
ci    As Integer
cj    As Integer
ck    As Integer
cu    As Long
End Type

Private Const MAXITEM   As Long = 5000    ' 记录5000个以内的结果
' 最多允许 32768个 ,但不宜太多(List控件太卡，用ListView控件可以考虑更多记录)

Private arrList() As ResultList
Private mlPoint   As Long

Private Sub cmdStartCombine_Click()
Dim a&, b&, c&, d As Long
Dim i&, j&, k&, m As Long

Dim fA&, fB&, fC  As Long
Dim uA&, uB&, uC  As Long
Dim wA&, wB&, wC  As Long

mlPoint = 0&
Call List1.Clear
TextI.Text = ""
TextJ.Text = ""
TextK.Text = ""
'  TextResult.Text = ""
TextResult.Text = "正在处理中………"

a = TextA.Text
b = TextB.Text
c = TextC.Text
d = TextD.Text

' 穷举i和j和k, 需要同时满足：
'     93    *i >  d*(a*i+b*j+c*k)
'  和 930   *j >  d*(a*i+b*j+c*k)
'  和 9000  *k >  d*(a*i+b*j+c*k)
fA = d * a
fB = d * b
fC = d * c

'   Dim ww As Long
'   ww = GetTickCount()
If (93& > fA) Then
For i = 1& To 10000&
DoEvents
uA = 93& * i
wA = fA * i
For j = 1& To 10000&
uB = 930& * j
wB = fB * j
m = wA + wB
If (uA < m) Then Exit For
If (uB > m) Then
For k = 1& To 10000&
uC = 9000& * k
wC = m + fC * k
If (uA <= wC) Then Exit For
If (uB <= wC) Then Exit For
If (uC <= wC) Then Exit For
arrList(mlPoint).ci = i
arrList(mlPoint).cj = j
arrList(mlPoint).ck = k
arrList(mlPoint).cu = wC
mlPoint = 1& + mlPoint

If (MAXITEM = mlPoint) Then
' 强制退出全部循环
i = 999999
j = 999999
Exit For
End If
Next           ' Next k
End If

Next                 ' Next j

Next                    ' Next i
End If
' 显示结果列表：
If (0& = mlPoint) Then
'  TextResult.Text = "没有这种组合！耗时" & GetTickCount() - ww & "mm"
TextResult.Text = "没有这种组合！"
Else
TextResult.Text = "组合完成。结果数：" & mlPoint
DoEvents
For i = 0& To mlPoint - 1&
& Format\$(arrList(i).cj, "   @@@@") _
& Format\$(arrList(i).ck, "   @@@@")
Next
End If
End Sub

' 事先分配好数据记录空间
ReDim arrList(MAXITEM - 1&)
End Sub

Private Sub List1_Click()
Dim strTemp As String
Dim i&, k   As Long

If (0& = mlPoint) Then Exit Sub
i = List1.ListIndex
k = arrList(i).ci
strTemp = "i = " & k & " ,  93 * i = " & (93& * k) & vbLf
k = arrList(i).cj
strTemp = strTemp & "j = " & k & " ,  930 * j = " & (930& * k) & vbLf
k = arrList(i).ck
strTemp = strTemp & "k = " & k & " ,  9000 * k = " & (9000& * k) & vbLf
strTemp = strTemp & "d*(a*i +b*j +c*k) = " & arrList(i).cu
Call MsgBox(strTemp, 64&, "结果信息")
End Sub``````

用于展示多条结果，点击相应的结果条目可以显示详细信息。
milaoshu1020 2021-05-07
• 打赏
• 举报

milaoshu1020 2021-05-07
• 打赏
• 举报

``````Option Explicit

Private Sub cmdStartCombine_Click()
TextI = ""
TextJ = ""
TextK = ""
TextResult = ""

Dim a As Long
a = TextA

Dim b As Long
b = TextB

Dim c As Long
c = TextC

Dim d As Long
d = TextD

Dim datStartTime As Date
datStartTime = Now

Dim i As Long
For i = 0 To 10000
DoEvents

Dim j As Long
For j = 0 To 10000
Dim k As Long
For k = 0 To 10000
Dim temp As Long
temp = d * (a * i + b * j + c * k)

If 93 * i > temp And 930 * j > temp And 9000 * k > temp Then
TextI = i
TextJ = j
TextK = k
TextResult = "组合完成."
Exit Sub
End If
Next
Next

Dim datNowTime As Date
datNowTime = Now

Dim lngSecondUsed As Long
lngSecondUsed = DateDiff("s", datStartTime, datNowTime)

Dim lngSecondTotal As Long
lngSecondTotal = lngSecondUsed * 10001 \ (i + 1)

Dim lngSecondRemain As Long
lngSecondRemain = lngSecondTotal - lngSecondUsed

Dim intHours As Integer
intHours = lngSecondRemain \ 3600

Dim intMinutes As Integer
intMinutes = lngSecondRemain \ 60 Mod 60

Dim intSeconds As Integer
intSeconds = lngSecondRemain Mod 60

TextResult = "剩余时间: " & intHours & ":" & intMinutes & ":" & intSeconds
Next

TextResult = "没有这种组合!"

End Sub
``````

• 打赏
• 举报

``````
Private Sub cmdStartCombine_Click()
TextI = ""
TextJ = ""
TextK = ""
TextResult = ""

Dim a As Long
a = Val(TextA)

Dim b As Long
b = Val(TextB)

Dim c As Long
c = Val(TextC)

Dim d As Long
d = Val(TextD)

Dim temp As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim tmp_bdj As Long

For i = 1 To 10000
'在这一层循环里，j和k 都是1，对判定条件2和3影响很小，暂不理会后面再算
If 93 <= a * d Then Exit For '

'前面的过滤门槛过了，就为下一层做准备
tmp_adi = a * d * i

For j = 1 To 10000
DoEvents
tmp_bdj = b * d * j
If 93 * i < temp Or 930 * j < temp Then Exit For

For k = 1 To 10000
temp = tmp_adi + tmp_bdj + c * d * k
'任何一个判定不满足就退出这层
If 93 * i <= temp Or 930 * j <= temp Or 9000 * k <= temp Then Exit For

'层层把关都过了，那么就是你想要的
TextI = i
TextJ = j
TextK = k
TextResult = "组合完成."
Exit Sub
Next
Next
Next

TextResult = "没有这种组合!"

End Sub
``````

• 打赏
• 举报

kevinvolvo 2021-05-07
• 打赏
• 举报

Cool body 2021-05-07
• 打赏
• 举报

• 打赏
• 举报

hainanzlt99 2021-05-07
• 打赏
• 举报

1,066

• 近7日
• 近30日
• 至今