VBA 这可能是一条数学题? ( 有详细步骤 )

liulang0808

On_fire 发表于 2023-1-6 09:46
版主好,
最小的C值的标准组合, 因有两个子元素,
所以这两个子元素的关连组合, 都是标准...

42楼回复了，楼主看下吧

On_fire

liulang0808 发表于 2023-1-6 10:25
42楼回复了，楼主看下吧

版主好,
因可能没把2当是准值, 答案有多, 也有少...

LIUZHU

liulang0808 发表于 2023-1-6 09:14
猜一下吧，供参考

结果不对，标准项不能和标准项求差，只能是非标项和标准项求差

On_fire

LIUZHU 发表于 2023-1-6 10:06
可以算吧，就是不知道实际意义在哪里？

意义就是求结果啊...

LIUZHU

写的JS，最近研究这个较多，VBA还真不一定写得出来

LIUZHU

附件，WPS测试，将就用吧

On_fire

LIUZHU 发表于 2023-1-6 11:01
写的JS，最近研究这个较多，VBA还真不一定写得出来

老师好,
因为这只是7个元素的模拟,
实际上, 如果是70个元素, 这算法就很有参考价值...

LIUZHU

On_fire 发表于 2023-1-6 11:08
老师好,
因为这只是7个元素的模拟,
实际上, 如果是70个元素, 这算法就很有参考价值...

如果是70个元素，算法要进行调整，因为代码中用了includes函数，比如元素2，会将2和21、22、23都筛选进来，结果就不对了。
原来的这个算法只能针对元素的大小不超过10的情况。

liulang0808

Sub 按钮1_Click()
    Dim crr()
    Dim wrr()
    Set d = CreateObject("scripting.dictionary")
    Set dd = CreateObject("scripting.dictionary")
    r = Cells(Rows.Count, "r").End(3).Row
    arr = [r1].Resize(r, 2)
    prr = Split(arr(2, 1), "-")
    For j = 2 To UBound(arr)
        For i = j + 1 To UBound(arr)
            If Val(arr(j, 2)) > Val(arr(i, 2)) Then
                tm = arr(j, 1)
                arr(j, 1) = arr(i, 1)
                arr(i, 1) = tm
                tm = arr(j, 2)
                arr(j, 2) = arr(i, 2)
                arr(i, 2) = tm
            End If
        Next i
    Next j
    For j = 2 To UBound(arr)
        If Val(arr(j, 2)) < 1000 Then
            brr = Split(arr(j, 1), "-")
            If Not d.exists(brr(0)) Then
                Set d(brr(0)) = CreateObject("scripting.dictionary")
            End If
            If Not d.exists(brr(1)) Then
                Set d(brr(1)) = CreateObject("scripting.dictionary")
            End If
            d(brr(0))(arr(j, 1)) = arr(j, 2)
            d(brr(1))(arr(j, 1)) = arr(j, 2)
        End If
    Next j
    ReDim crr(1 To d.Count * d.Count, 1 To 7)
    r = 0
   
    For Each k In d.keys
        If k <> prr(0) And k <> prr(1) Then
            brr = d(k).keys
            a = 0
            dd.RemoveAll
            For j = LBound(brr) To UBound(brr)
                drr = Split(brr(j), "-")
                If drr(0) = prr(0) Or drr(1) = prr(0) Or drr(0) = prr(1) Or drr(1) = prr(1) Then
                    a = a + 1
                    ReDim Preserve wrr(1 To 2, 1 To a)
                    dd(brr(j)) = ""
                    wrr(1, a) = brr(j)
                    wrr(2, a) = d(k)(brr(j))
                End If
            Next j
            If a > 0 Then
                For j = 1 To a
                    For Each kk In d(k).keys
                        If Not dd.exists(kk) Then
                            If Val(wrr(2, j)) >= d(k)(kk) Then
                                r = r + 1
                                crr(r, 1) = k
                                crr(r, 2) = kk
                                crr(r, 3) = d(k)(kk)

                                crr(r, 4) = wrr(1, j)
                                crr(r, 5) = wrr(2, j)
                                crr(r, 6) = Val(crr(r, 3)) - Val(crr(r, 5))
                            End If
                        End If
                    Next kk
                Next j
            End If
        End If
    Next k
    If r > 0 Then
        [u2].Resize(r, 6) = crr
    End If
End Sub

On_fire

LIUZHU 发表于 2023-1-6 11:21
如果是70个元素，算法要进行调整，因为代码中用了includes函数，比如元素2，会将2和21、22、23都筛选进来 ...

恳求老师调整...万分感谢...