VBA解近似值代码

zopey

在没有算法支持的时候，计算机是穷举所有组合 求解（暴力法），
数据量小的还可以尝试，当组合数 过亿以后，并不可取。

sky_forest

lsdongjh 发表于 2019-3-25 14:10
简易化处理，结果做了去重，如果不去重，可以直接用二维数组装载并显示

BUG反馈来了，调整精度至6位后出错，i 值增加有效数字后也有报错，a 列的单元格格式每次计算后都会刷掉。另外想到一个，第一列数组是固定的，有没可能单独一个标签页把所有的组合输出，这样的话计算的时候只需要作减法对比就可以了，能减少运算量，会不会更快一点。

mzbao

1. Sub test()
   
2.     Dim arr(), j As Double, k As Double, i As Double, ij As Double
   
3.     Dim rArr(), n%, num, a, b, c, d, w%, x%, y%, z%, kk&
   
4.    
   
5.     arr = Range("A1:A41").Value
   
6.     n = UBound(arr)
   
7.     num = Application.Combina(n, 4)
   
8.     j = [C2].Value: k = [D2].Value
   
9.     ReDim rArr(1 To num, 1 To 6)
   
10.    
    
11.     For w = 1 To n
    
12.         a = arr(w, 1)
    
13.         For x = 1 To n
    
14.             If x <> w Then
    
15.                 b = arr(x, 1)
    
16.                 For y = 1 To n
    
17.                     If y <> w And y <> x Then
    
18.                         c = arr(y, 1)
    
19.                         For z = 1 To n
    
20.                             If z <> w And z <> x And z <> y Then
    
21.                                 d = arr(z, 1)
    
22.                                 i = a / b * c / d
    
23.                                 ij = Abs(i - j)
    
24.                                 If ij < k Then
    
25.                                     kk = kk + 1
    
26.                                     rArr(kk, 1) = a
    
27.                                     rArr(kk, 2) = b
    
28.                                     rArr(kk, 3) = c
    
29.                                     rArr(kk, 4) = d
    
30.                                     rArr(kk, 5) = i
    
31.                                     rArr(kk, 6) = i - j
    
32.                                 End If
    
33.                             End If
    
34.                         Next z
    
35.                     End If
    
36.                 Next y
    
37.             End If
    
38.         Next x
    
39.     Next w
    
40.     If kk > 0 Then
    
41.         Range("F10").Resize(kk, 6) = rArr
    
42.     Else
    
43.         MsgBox "没有结果"
    
44.     End If
    
45. End Sub

复制代码

sky_forest

mzbao 发表于 2019-3-26 14:28

说运行错误？