VBA解近似值代码

sky_forest

有4个变量a，b，c，d，从A1中选取，不可重复，有i=a/b*c/d，有常数j，k，如|i-j|<k，则输出a，b，c，d，i，i-j的值

yjh_27

30	68	76	97	0.345664039	-5.96119E-06
30	78	71	79	0.345666991	-3.00876E-06
30	79	71	78	0.345666991	-3.00876E-06
30	97	76	68	0.345664039	-5.96119E-06
40	68	57	97	0.345664039	-5.96119E-06
40	97	57	68	0.345664039	-5.96119E-06
44	94	96	130	0.345662848	-7.15221E-06
44	130	96	94	0.345662848	-7.15221E-06
48	94	88	130	0.345662848	-7.15221E-06
48	130	88	94	0.345662848	-7.15221E-06
57	68	40	97	0.345664039	-5.96119E-06
57	97	40	68	0.345664039	-5.96119E-06
71	78	30	79	0.345666991	-3.00876E-06
71	79	30	78	0.345666991	-3.00876E-06
76	68	30	97	0.345664039	-5.96119E-06
76	97	30	68	0.345664039	-5.96119E-06
88	94	48	130	0.345662848	-7.15221E-06
88	130	48	94	0.345662848	-7.15221E-06
96	94	44	130	0.345662848	-7.15221E-06
96	130	44	94	0.345662848	-7.15221E-06

sky_forest

yjh_27 发表于 2019-3-24 11:49

大佬，能给代码吗

microyip

这个实际就是根据A列，罗列出所有的a\b\c\d四个值而已，至于计算比较什么的，固定的，剔除不符合条件就可以得到结果了。找找如何罗列数据的帖子抄一下代码即可

yjh_27

是的，41选4的排列。需计算2430480次。
a、c级b、d位置可对换。所以也可以认为是分组组合问题。

sky_forest

yjh_27 发表于 2019-3-25 10:37
是的，41选4的排列。需计算2430480次。
a、c级b、d位置可对换。所以也可以认为是分组组合问题。

数学原理我知道，但没学过编程，不会写代码，能把代码发给我吗

sky_forest

microyip 发表于 2019-3-25 08:47
这个实际就是根据A列，罗列出所有的a\b\c\d四个值而已，至于计算比较什么的，固定的，剔除不符合条件就可以 ...

隔行如隔山，“即可”让我很无奈

lsdongjh

简易化处理，结果做了去重，如果不去重，可以直接用二维数组装载并显示

1. Option Explicit
   
2. 
   
3. Sub Test()
   
4.     Dim Sh As Worksheet, lngRows As Long
   
5.     Dim arrData As Variant, objDic As Object, objDicResult As Object
   
6.     Dim dblConstant As Double '常数
   
7.     Dim dblAccuracy As Double '精度
   
8.     Dim dblDeviation As Double '误差
   
9.     Dim dblI As Double, strKey As String
   
10.     Dim lngA As Long, lngB As Long, lngC As Long, lngD As Long
    
11.     Dim dblA As Double, dblB As Double, dblC As Double, dblD As Double
    
12.    
    
13.     Set objDic = CreateObject("Scripting.Dictionary")
    
14.     Set objDicResult = CreateObject("Scripting.Dictionary")
    
15.     Set Sh = Sheets("Sheet1")
    
16.     lngRows = Sh.Range("A" & Rows.Count).End(xlUp).Row
    
17.     arrData = Sh.Range("A1:A" & lngRows)
    
18.    
    
19.     dblConstant = Sh.Range("C2").Value
    
20.     dblAccuracy = Sh.Range("D2").Value
    
21.    
    
22.     For lngA = 1 To lngRows
    
23.         objDic.RemoveAll
    
24.         dblA = arrData(lngA, 1)
    
25.         objDic(dblA) = ""
    
26.         For lngB = 1 To lngRows
    
27.             dblB = arrData(lngB, 1)
    
28.             If objDic.Exists(dblB) = False Then
    
29.                 objDic(dblB) = ""
    
30.                 For lngC = 1 To lngRows
    
31.                     dblC = arrData(lngC, 1)
    
32.                     If objDic.Exists(dblC) = False Then
    
33.                         objDic(dblC) = ""
    
34.                         For lngD = 1 To lngRows
    
35.                             dblD = arrData(lngD, 1)
    
36.                             If objDic.Exists(dblD) = False Then
    
37.                                 objDic(dblD) = ""
    
38.                                 dblI = dblA / dblB * dblC / dblD
    
39.                                 dblDeviation = dblI - dblConstant
    
40.                                 If Abs(dblDeviation) < dblAccuracy Then
    
41.                                     strKey = dblA & "," & dblB & "," & dblC & "," & dblD & "," & dblI & "," & dblDeviation
    
42.                                     objDicResult(strKey) = ""
    
43.                                 End If
    
44.                                 objDic.Remove dblD
    
45.                             End If
    
46.                         Next
    
47.                         objDic.Remove dblC
    
48.                     End If
    
49.                 Next
    
50.                 objDic.Remove dblB
    
51.             End If
    
52.         Next
    
53.     Next
    
54.    
    
55.     arrData = Application.WorksheetFunction.Transpose(objDicResult.keys)
    
56.     lngRows = UBound(arrData)
    
57.    
    
58.     Sh.Range("F2:F" & Rows.Count).Clear
    
59.     Sh.Range("F2").Resize(lngRows, 1) = arrData
    
60.     Sh.Range("F2").Resize(lngRows, 1).TextToColumns Destination:=Range("F2"), DataType:=xlDelimited, Comma:=True
    
61.    
    
62.     MsgBox "OK"
    
63. End Sub

复制代码

microyip

那么你是来这里要结果？还是来学习的呢？

sky_forest

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

非常感谢，我自己真心写不出来，要完全看懂估计都得费很多时间学习，真心感谢！