提速度

lgzxmlg

网上找的代码进行了修改，运行速度较慢。有好的方法吗？


Sub DF2024()
    Dim SJ As Double
    Dim BZ As Double
    Dim i As Integer
    R = Sheet5.Cells(Rows.Count, "B").End(xlUp).Row
    For i = 4 To R
        SJ = Range("E" & i).Value
        Select Case SJ
            Case Is <= 0
                BZ = 0
            Case 0 To 3000
                BZ = 0.005
            Case 3000 To 5000
                BZ = 0.01
            Case 5000 To 10000
                BZ = 0.015
            Case Is > 10000
                BZ = 0.02
            End Select
        Sheet5.Range("F" & i).Value = BZ
        Sheet5.Range("G" & i).Value = WorksheetFunction.Round(SJ * BZ, 0)
          Next i
End Sub

titi012

改用数组，这样应该会快很多。。。
如果还慢，改用二分法判断，再减少一半的判断量。

lgzxmlg

titi012 发表于 2024-1-5 15:13
改用数组，这样应该会快很多。。。
如果还慢，改用二分法判断，再减少一半的判断量。

老师给个代码吧

shiruiqiang

没附件说啥啊

ykcbf1100

没附件无从下手。

lgzxmlg

ykcbf1100 发表于 2024-1-5 20:33
没附件无从下手。

附件 123.zip (14.61 KB, 下载次数: 3)

2024-1-5 21:29 上传

点击文件名下载附件

是否还有更好的方法。学习下。

ykcbf1100

lgzxmlg 发表于 2024-1-5 21:31
附件 是否还有更好的方法。学习下。

附件供参考。。。

lgzxmlg

ykcbf1100 发表于 2024-1-5 21:52
附件供参考。。。

谢谢。学习了。

titi012

参与一下。。。

1. Sub text()
   
2.     Dim Arr, Brr(), Nrr, Mrr, x&, y%
   
3.     Arr = Range("e4:e" & Cells(Rows.Count, 2).End(xlUp).Row).Value
   
4.     ReDim Brr(1 To UBound(Arr), 1 To 2)
   
5.     Nrr = Array(0, 3000, 5000, 10000)
   
6.     Mrr = Array(0.005, 0.01, 0.015, 0.02)
   
7.     For x = 1 To UBound(Arr)
   
8.         For y = 3 To 0 Step -1
   
9.             If Arr(x, 1) > Nrr(y) Then
   
10.                 Brr(x, 1) = Mrr(y)
    
11.                 Brr(x, 2) = Arr(x, 1) * Brr(x, 1)
    
12.                 Exit For
    
13.             End If
    
14.     Next y, x
    
15.     Range("F4").Resize(UBound(Arr), 2) = Brr
    
16. End Sub

复制代码

lgzxmlg

titi012 发表于 2024-1-6 09:31
参与一下。。。

谢谢老师给出的代码。学习了。