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

liulang0808

On_fire 发表于 2023-1-5 20:21
老师好,

RS列，1-2:3.9这组合,

所谓的标准值之间不做相关操作吧，只是对标准值跟非标准值之间做处理吗 ？
附件模拟数据还是看不大明白。
包含1，2的都是标准值啊。。。。。

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
            For j = LBound(brr) To UBound(brr)
                drr = Split(brr(j), "-")
                If drr(0) = prr(0) Or drr(1) = prr(0) Or drr(1) = prr(0) Or drr(1) = prr(1) Then
                    a = a + 1
                    ReDim Preserve wrr(1 To 2, 1 To a)
                    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 wrr(1, j) <> 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

liulang0808

猜一下吧，供参考

On_fire

LIUZHU 发表于 2023-1-6 00:45
当没有排除掉和标准项C值的差大于0的数据时，结果如下，不知道是否正确？

老师好,
如用Sheet1的RS资料, 您是对的…

On_fire

LIUZHU 发表于 2023-1-6 00:46
如果排除掉和标准项C值的差大于0，就只有三个了

老师好,
如用Sheet1(2)的RS资料, 代码的结果跟模拟一样吗?

On_fire

liulang0808 发表于 2023-1-6 08:36
所谓的标准值之间不做相关操作吧，只是对标准值跟非标准值之间做处理吗 ？
附件模拟数据还是看不大明白 ...

版主好,
最小的C值的标准组合, 因有两个子元素,
所以这两个子元素的关连组合, 都是标准...

LIUZHU

On_fire 发表于 2023-1-6 09:34
老师好,
如用Sheet1(2)的RS资料, 代码的结果跟模拟一样吗?

用Sheet2的数据结果是这样的

On_fire

LIUZHU 发表于 2023-1-6 09:55
用Sheet2的数据结果是这样的

老师好,
是的, 一样
请问您觉是不是一道数学题?

LIUZHU

On_fire 发表于 2023-1-6 09:57
老师好,
是的, 一样
请问您觉是不是一道数学题?

可以算吧，就是不知道实际意义在哪里？

LIUZHU

On_fire 发表于 2023-1-6 09:57
老师好,
是的, 一样
请问您觉是不是一道数学题?

添加排序代码后，计算的结果和你的完全一致了