VBA暴力求解欠定方程组谜题的性能优化求助
2026-7-3
VBA暴力枚举求解欠定方程组的优化方案
问题背景
刚入学时碰到一道谜题，当年数学知识不够解不出来。多年后发现这是个包含10个公式、12个未知数的欠定系统，且至少存在一个解。最近用VBA暴力枚举求解，虽然找到了已知解，但12层嵌套循环速度极慢——变量范围1-100时要跑约15分钟，没法高效获取全部解，急需代码优化方案。
原代码
For a = 1 To 100 For b = 1 To 100 If 10 - a + 38 + b * 42 = 114 Then For c = 1 To 100 For d = 1 To 100 For e = 1 To 100 If c - 2 + d + 6 * e = 37 Then For f = 1 To 100 For g = 1 To 100 If 50 - f * 3 - g / 5 = -4 Then For h = 1 To 100 For j = 1 To 100 For k = 1 To 100 If h + 15 - j * 3 - k = 2 Then For l = 1 To 1000 For m = 1 To 100 If 20 * l + 12 / m + 8 = 171 Then If 10 + c * 50 + h + 20 = 186 Then If a * 2 - f + 15 - l = 111 Then If 38 - d * 3 - j + 12 = -28 Then If b + 6 + g - 3 * m = 27 Then If 42 * e - 5 - k - 8 = 70 Then r = r + 1 With Worksheets("Sheet1") .Cells(r, 5).Value = a .Cells(r, 6).Value = b .Cells(r, 7).Value = c .Cells(r, 8).Value = d .Cells(r, 9).Value = e .Cells(r, 10).Value = f .Cells(r, 11).Value = g .Cells(r, 12).Value = h .Cells(r, 13).Value = j .Cells(r, 14).Value = k .Cells(r, 15).Value = l .Cells(r, 16).Value = m .Cells(r, 4).Value = Format(Timer - t, "hh:mm:ss") End With End If End If End If End If End If End If Next m Next l End If Next k Next j Next h End If Next g Next f End If Next e Next d Next c End If Next b Next a
优化思路与方案
暴力枚举慢的核心原因是无效循环太多，以及深层循环里的重复计算和高频IO操作。优化从以下几点入手：
1. 代数化简，直接缩小变量范围甚至确定变量值
先逐个拆解原方程组，把能直接推导的变量关系理清楚，砍掉不必要的循环：
- 从
10 - a + 38 + 42*b = 114得a = 42*b - 66，结合a∈[1,100]，直接得出b只能是2或3，a对应18或60，无需循环1-100 - 从
50 - 3*f - g/5 = -4得g = 15*(18-f)，结合g∈[1,100]，得出f∈[12,17]，g由f直接计算，无需循环g - 从
20*l + 12/m +8 =171，因m是正整数且12/m必须为整数（保证等式左边为整数），遍历12的因数后，仅m=4、l=8满足条件，直接确定这两个变量值 - 从
10 +50*c +h +20=186得h=156-50*c，结合h∈[1,100]，得出c只能是2或3，h对应56或6，无需循环c和h - 从
2*a -f +15 -l=111，代入l=8得f=2*a-104，结合f∈[12,17]，直接确定a=60、b=3、f=16、g=30 - 剩余变量通过联立方程进一步缩小范围，最终仅需循环少量变量即可
2. 关闭Excel后台功能，减少运行开销
执行代码前关闭屏幕更新、自动计算、事件触发等，避免不必要的资源消耗。
3. 批量写入结果，减少IO操作
原代码逐行写入工作表，IO操作是性能瓶颈之一。先把结果存到数组里，最后一次性写入工作表。
优化后的代码
Sub OptimizedSolve() Dim t As Double, r As Integer Dim a As Integer, b As Integer, c As Integer, d As Integer Dim e As Integer, f As Integer, g As Integer, h As Integer Dim j As Integer, k As Integer, l As Integer, m As Integer Dim resultArr() As Variant Dim idx As Integer ' 初始化计时与结果数组 t = Timer r = 0 ReDim resultArr(1 To 100, 1 To 12) ' 预留足够空间 ' 关闭Excel后台功能 With Application .ScreenUpdating = False .Calculation = xlCalculationManual .EnableEvents = False End With ' 已通过化简确定的变量 l = 8 m = 4 a = 60 b = 3 f = 16 g = 30 ' 遍历剩余可变量：c的可能值为2、3 For c = 2 To 3 Step 1 h = 156 - 50 * c ' h必须在1-100范围内（c=1时h=106超出，已排除） If h >= 1 And h <= 100 Then ' 由38-3*d -j +12=-28得j=78-3*d For d = 1 To 25 j = 78 - 3 * d If j >= 1 Then ' 由h+15-3*j -k=2得k=h -3*j +13 k = h - 3 * j + 13 If k >= 1 And k <= 100 Then ' 由42*e -5 -k -8=70得k=42*e -83 e = (k + 83) / 42 ' 验证e是否为整数且在1-6范围内 If e = Int(e) And e >= 1 And e <= 6 Then ' 验证第二个条件c+d+6e=39 If c + d + 6 * e = 39 Then r = r + 1 idx = idx + 1 ' 存入数组 resultArr(idx, 1) = a resultArr(idx, 2) = b resultArr(idx, 3) = c resultArr(idx, 4) = d resultArr(idx, 5) = e resultArr(idx, 6) = f resultArr(idx, 7) = g resultArr(idx, 8) = h resultArr(idx, 9) = j resultArr(idx, 10) = k resultArr(idx, 11) = l resultArr(idx, 12) = m End If End If End If End If Next d End If Next c ' 批量写入工作表 If r > 0 Then With Worksheets("Sheet1") .Range(.Cells(1, 5), .Cells(r, 16)).Value = resultArr .Range(.Cells(1, 4), .Cells(r, 4)).Value = Format(Timer - t, "hh:mm:ss") End With End If ' 恢复Excel后台功能 With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic .EnableEvents = True End With MsgBox "求解完成，共找到" & r & "个解，耗时：" & Format(Timer - t, "hh:mm:ss") End Sub
优化效果
优化后代码几乎没有无效循环，运行时间从原来的15分钟缩短到毫秒级，同时避免了高频IO操作带来的性能损耗。如果后续遇到类似的欠定方程组问题，核心思路都是先通过代数化简缩小变量范围，再减少不必要的循环和IO操作。
内容的提问来源于stack exchange，提问作者ddkking
相关产品推荐
相关产品推荐
