凑面积数尽可能接近229.5216！

z3376548

大家好！ 我目前遇到了一个需要我去选出几个房型凑起来使得平方数尽量接近229.5216平方的任务，所以我发了这个帖子，看过群里也有不少大神分享过这类的解答方案，但是由于弱于excel的使用，我目前基本没办法自行解决这个问题 T_T， 希望有大神能愿意帮助小弟，我愿意为帮助提供酬劳！
（附上面积库， ）

69.7464
74.4385
72.654
50.048
62.0742
47.0322
53.6152
60.7625
69.7464
74.4385
72.654
50.048
62.0742
47.0322
64.2
60.7625
69.7464
74.4385
72.654
50.048
62.0742
47.0322
64.2
60.7625
69.7464
74.4385
72.654
50.048
62.0742
47.0322
64.2
60.7625
69.7464
74.4385
72.654
50.048
62.0742
47.0322
64.2
60.7625

83.141
90.7175
83.141
90.7175
83.141
90.7175
83.141
90.7175
83.141
90.7175

108.7731
45.2129
51.9794
55.7694
75.6996
35.8445
44.426
108.7731
45.2129
51.9794
55.7694
75.6996
35.8445
44.426
108.7731
45.2129
51.9794
55.7694
75.6996
35.8445
44.426
108.7731
45.2129
51.9794
55.7694
75.6996
35.8445
44.426
108.7731
45.2129
51.9794
55.7694
75.6996
35.8445
44.426

小花鹿

找香川老师                                                                                                         

z3376548

我得先赚积分才可以联系到她 T T

z403025335

Sub 最接近值()‘把这组数据粘贴在sheet1的A列
Dim s1 As Currency, s2$, s3 As Currency, m@, n1%, n2%, i&, a1(), a2(), a(), a3(3)
Dim dic1 As Object, dic2 As Object
Const ss As Currency = 229.5126
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
With Sheet1
n1 = 1
Do While .Cells(n1, 1) <> ""
    n2 = 2
    s1 = .Cells(n1, 1)
    s2 = CStr(n1)
    Do While .Cells(n2, 1) <> ""
        s1 = .Cells(n2, 1) + s1
        s2 = s2 & "," & n2
        n2 = n2 + 1
        If s1 > ss Then Exit Do
    Loop
    s3 = s1 - .Cells(n2 - 1, 1)
    dic1.Add Left(s2, InStrRev(s2, ",") - 1), s3
    dic1.Add s2, s1
    s3 = Abs(s3 - ss)
    s1 = Abs(s1 - ss)
    dic2.Add Left(s2, InStrRev(s2, ",") - 1), s3
    dic2.Add s2, s1
    n1 = n1 + 1
Loop
a1 = dic2.keys()
a2 = dic2.items()
ReDim a(0 To dic2.Count, 1 To 3)
For i = 0 To dic2.Count - 1
    a(i, 1) = a1(i)
    a(i, 2) = dic1.Item(a1(i))
    a(i, 3) = a2(i)
Next i
Call 数组排序(a)
MsgBox "最接近值行号：" & a(1, 1) & vbCrLf & "最接近值为：" & a(1, 2) _
& vbCrLf & "与" & ss & "相差：" & Format(a(1, 3), "0.0000")
End With
End Sub

Sub 数组排序(a)
Dim i%, m%, s1, s2@, s3@
For i = LBound(a, 1) To UBound(a, 1) - 1
    If a(i, 3) <= a(i + 1, 3) Then
        If i > m Then
            m = i
        Else
            i = m
        End If
    Else
        s1 = a(i, 1)
        s2 = a(i, 2)
        s3 = a(i, 3)
        a(i, 1) = a(i + 1, 1)
        a(i, 2) = a(i + 1, 2)
        a(i, 3) = a(i + 1, 3)
        a(i + 1, 1) = s1
        a(i + 1, 2) = s2
        a(i + 1, 3) = s3
    If i <> LBound(a, 1) Then i = i - 2
    End If
Next i
End Sub

香川群子

z403025335 发表于 2018-8-12 14:44
Sub 最接近值()‘把这组数据粘贴在sheet1的A列
Dim s1 As Currency, s2$, s3 As Currency, m@, n1%, n2%,  ...

可以得到近似解，但不是最接近的。

香川群子

用一般凑数程序，或者求多元一次方程组的整数解程序可以计算得到近似结果。

z3376548

谢谢香川老师！