[已解决]求助一个快速对比并返回的代码

ryoryo66

H2以前的公式是:如果h8 = 0 or h8 = 1 or h8 > 400,则为空,然后h8 >= h7 并且h8 >="断断"的h7:h8,则返回 "有".
h3以前的公式是:如果h8 = 0 or h8 = 1 or h8 > 400,则为空,然后h8 >= h7的值+1 并且h8 >="断断"的h7:h8的值+1,则返回 "有".
h4以前的公式是:如果h8 = 0 or h8 = 1 or h8 > 400,则为空,然后h8 >= h7的值+2 并且h8 >="断断"的h7:h8的值+2,则返回 "有".
经过多次检查,这个简单的公式导致了打开工作簿的过程太慢,老师能不能帮我用数组或字典这种快速返回的代码写一下.
范围就是H2:P2,H3:P3,H4:P4;
后面的工作表也是同样的模式,都只是引用"断断"这个表."断断"表的范围内引用其自身的位置.共有断断,1.2.3....20个表,这里因为容量问题,就显示了4个.

最佳答案

月排行榜 / 总排行榜

shuidisyy

2021-3-24 16:12

Sub test()
    Dim arrData, arrResult, arrList
    Dim k, i, j
    arrList = Sheets("断断").Range("h7:p8").Value
    For k = 1 To 3
        With Sheets(CStr(k))
            arrData = .Range("h7:p8").Value
            ReDim arrResult(0 To 2, 1 To UBound(arrData, 2))
            For j = 1 To UBound(arrData, 2)
                For i = 0 To 2
                    If arrData(2, j) = 1 Or arrData(2, j) = 0 Or arrData(2, j) > 400 Then
                        arrResult(i, j) = ""
                    Else
                        If arrData(2, j) >= arrData(1, j) + i Then
                            If arrData(2, j) >= arrList(1, j) + i And arrData(2, j) >= arrList(2, j) + i Then
                                arrResult(i, j) = "有"
                            End If
                        End If
                    End If
                Next i
            Next j
            .Range("h2").Resize(UBound(arrResult) + 1, UBound(arrResult, 2)) = arrResult
        End With
    Next k
End Sub

跳转到最佳答案楼层

shuidisyy

Sub test()
    Dim arrData, arrResult, arrList
    Dim k, i, j
    arrList = Sheets("断断").Range("h7:p8").Value
    For k = 1 To 3
        With Sheets(CStr(k))
            arrData = .Range("h7:p8").Value
            ReDim arrResult(0 To 2, 1 To UBound(arrData, 2))
            For j = 1 To UBound(arrData, 2)
                For i = 0 To 2
                    If arrData(2, j) = 1 Or arrData(2, j) = 0 Or arrData(2, j) > 400 Then
                        arrResult(i, j) = ""
                    Else
                        If arrData(2, j) >= arrData(1, j) + i Then
                            If arrData(2, j) >= arrList(1, j) + i And arrData(2, j) >= arrList(2, j) + i Then
                                arrResult(i, j) = "有"
                            End If
                        End If
                    End If
                Next i
            Next j
            .Range("h2").Resize(UBound(arrResult) + 1, UBound(arrResult, 2)) = arrResult
        End With
    Next k
End Sub

ryoryo66

shuidisyy 发表于 2021-3-24 16:12
Sub test()
    Dim arrData, arrResult, arrList
    Dim k, i, j

非常感谢老师,辛苦了.
这是工程师级别的高手 .

ryoryo66

shuidisyy 发表于 2021-3-24 16:12
Sub test()
    Dim arrData, arrResult, arrList
    Dim k, i, j

大师啊.能不能再帮我看看最后一个代码.提取的

http://www.excelpx.com/forum.php ... d=462239&extra=

辛苦您了.

ryoryo66

shuidisyy 发表于 2021-3-24 16:12
Sub test()
    Dim arrData, arrResult, arrList
    Dim k, i, j

尊敬的大师,再帮我看看最后一个吧.

ryoryo66

shuidisyy 发表于 2021-3-24 16:12
Sub test()
    Dim arrData, arrResult, arrList
    Dim k, i, j

亲爱的大师,就是这个问题,Sheets(CStr(k)) 对比"断断"表格返回 "有" 是没有问题了.但是还有一个 "断断"表格也需要判断返回 他的在h8 = 0 or h8 = 1 or h8 > 400,则为空的基础上,判断自身h8 >= h7 + 0 ,1, 2,再单独返回 "有".这个一直没有加上.

能不能再麻烦看看怎么加上啊?