为C列自定义函数的代码运算提速

YZC51

13782671637 发表于 2018-6-18 19:22
老师：是不是代码无法计算文本类数字？为什么下面蓝桥玄霜版主的代码能显示正确结果呢？Sub 冷码1()
    ...

原因找到啦！是因为设置了《单元格格式》程序误以为46984行之内都有数据，所有计算空值时出错！
已经增加错误处理，请参考。
Sub 冷码()
    Dim brr(), sr()
    tms = Timer
    n = [c2]'
    m = Cells(n, 2).End(3).Row - 4
    If m < 5 Then m = n - 4
    [C5].Resize(m) = ""
    ar = [B5].Resize(m)
    ReDim sr(1 To m, 1 To 1)     
    ReDim brr(0 To 2)
    For I = 1 To m
        t = ar(I, 1): t1 = Left(t, 1)
        brr(t1) = brr(t1) + 1: If brr(t1) = 1 Then k1 = k1 + 1
        If k1 = 2 Then k1 = I: Exit For
    Next
    s1 = 3 - Left(ar(1, 1), 1) - Left(ar(k1, 1), 1)
    ReDim brr(0 To 2)
    For I = 1 To m
        t = ar(I, 1):  t2 = Right(t, 1)
        brr(t2) = brr(t2) + 1: If brr(t2) = 1 Then k2 = k2 + 1
        If k2 = 2 Then k2 = I: Exit For
    Next
    s2 = 3 - Right(ar(1, 1), 1) - Right(ar(k2, 1), 1)
    s = s1 & s2   
    If k1 > k2 Then k0 = k1 Else k0 = k2
    For I = k0 To m
        t = ar(I - 1, 1): t11 = Left(t, 1): t12 = Right(t, 1)
        t = ar(I, 1): t21 = Left(t, 1): t22 = Right(t, 1)
On Error GoTo JS
        If t11 = t21 Then s1 = Left(s, 1) Else s1 = 3 - t11 - t21
        If t12 = t22 Then s2 = Right(s, 1) Else s2 = 3 - t12 - t22
        s = s1 & s2
        sr(I, 1) = s
    Next
JS:
    [C5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

13782671637

YZC51 发表于 2018-6-18 20:15
原因找到啦！是因为设置了《单元格格式》程序误以为46984行之内都有数据，所有计算空值时出错！
已经增 ...

老师：如果需要改变指定截止行号、数据源列标、计算结果显示列标，只需要修改下面4处么？
Sub 冷码()
    Dim brr(), sr()
    tms = Timer
    n = [c2]'
    m = Cells(Rows.Count, 1).End(3).Row - 4
    m = Cells(n, 2).End(3).Row - 4
    If m < 5 Then m = n - 4
'    [C5].Resize(m) = ""
    ar = [B5].Resize(m)
    ReDim sr(1 To m, 1 To 1)     
    ReDim brr(0 To 2)
    For I = 1 To m
        t = ar(I, 1): t1 = Left(t, 1)
        brr(t1) = brr(t1) + 1: If brr(t1) = 1 Then k1 = k1 + 1
        If k1 = 2 Then k1 = I: Exit For
    Next
    s1 = 3 - Left(ar(1, 1), 1) - Left(ar(k1, 1), 1)
    ReDim brr(0 To 2)
    For I = 1 To m
        t = ar(I, 1):  t2 = Right(t, 1)
        brr(t2) = brr(t2) + 1: If brr(t2) = 1 Then k2 = k2 + 1
        If k2 = 2 Then k2 = I: Exit For
    Next
    s2 = 3 - Right(ar(1, 1), 1) - Right(ar(k2, 1), 1)
    s = s1 & s2   
    If k1 > k2 Then k0 = k1 Else k0 = k2
    For I = k0 To m
        t = ar(I - 1, 1): t11 = Left(t, 1): t12 = Right(t, 1)
        t = ar(I, 1): t21 = Left(t, 1): t22 = Right(t, 1)
On Error GoTo JS
        If t11 = t21 Then s1 = Left(s, 1) Else s1 = 3 - t11 - t21
        If t12 = t22 Then s2 = Right(s, 1) Else s2 = 3 - t12 - t22
        s = s1 & s2
        sr(I, 1) = s
    Next
JS:
    [C5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

13782671637

YZC51 发表于 2018-6-18 20:15
原因找到啦！是因为设置了《单元格格式》程序误以为46984行之内都有数据，所有计算空值时出错！
已经增 ...

老师：经测试，计算结果已显示正确。总是麻烦您，是因为您修改的代码要比90楼的运算速度要快0.5~0.8秒左右。谢谢老师的耐心帮忙！

13782671637

13782671637 发表于 2018-6-18 20:20
老师：如果需要改变指定截止行号、数据源列标、计算结果显示列标，只需要修改下面4处么？
Sub 冷码()
  ...

今天鲜花送完了，让玉阳山人代替本人【其实是一个人，两个名字】致谢！

YZC51

修改
1、修改截止行：只需修改[C2]内的数字即可；
2、数据源列标：假设A列--修改为B列
2.1              m = Cells(n, 1).End(3).Row - 4
      修改为   m = Cells(n, 2).End(3).Row - 4
2.2              ar = [A5].Resize(m)
      修改为   ar = [B5].Resize(m)

3、计算结果显示列标，假设B列--修改为C列
          [B5].Resize(m) = sr
   修改为 [C5].Resize(m) = sr
4、OK

YZC51

13782671637 发表于 2018-6-18 20:31
今天鲜花送完了，让玉阳山人代替本人【其实是一个人，两个名字】致谢！

同病相怜，就不必客气！

YZC51

经过测试90楼代码是最快的！！！

13782671637

YZC51 发表于 2018-6-18 20:35
修改
1、修改截止行：只需修改[C2]内的数字即可；
2、数据源列标：假设A列--修改为B列

Sub 冷码()
    Dim brr(), sr()
    tms = Timer
    n = [c2]'
    m = Cells(n, 2).End(3).Row - 4   老师：我让C2维持原状，把数据源改为A列，计算列改为B列,没有改动m = Cells(n, 2).End(3).Row - 4  里边的2
    If m < 5 Then m = n - 4                            ，为什么得出的结果仍然正确？
'    [C5].Resize(m) = ""
    ar = [B5].Resize(m)
    ReDim sr(1 To m, 1 To 1)     
    ReDim brr(0 To 2)
    For I = 1 To m
        t = ar(I, 1): t1 = Left(t, 1)
        brr(t1) = brr(t1) + 1: If brr(t1) = 1 Then k1 = k1 + 1
        If k1 = 2 Then k1 = I: Exit For
    Next
    s1 = 3 - Left(ar(1, 1), 1) - Left(ar(k1, 1), 1)
    ReDim brr(0 To 2)
    For I = 1 To m
        t = ar(I, 1):  t2 = Right(t, 1)
        brr(t2) = brr(t2) + 1: If brr(t2) = 1 Then k2 = k2 + 1
        If k2 = 2 Then k2 = I: Exit For
    Next
    s2 = 3 - Right(ar(1, 1), 1) - Right(ar(k2, 1), 1)
    s = s1 & s2   
    If k1 > k2 Then k0 = k1 Else k0 = k2
    For I = k0 To m
        t = ar(I - 1, 1): t11 = Left(t, 1): t12 = Right(t, 1)
        t = ar(I, 1): t21 = Left(t, 1): t22 = Right(t, 1)
On Error GoTo JS
        If t11 = t21 Then s1 = Left(s, 1) Else s1 = 3 - t11 - t21
        If t12 = t22 Then s2 = Right(s, 1) Else s2 = 3 - t12 - t22
        s = s1 & s2
        sr(I, 1) = s
    Next
JS:
    [C5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

13782671637

YZC51 发表于 2018-6-18 21:12
经过测试90楼代码是最快的！！！

怪了，我测90楼的代码总是在0.28~0.36秒之间，而您91楼的代码大部分都在0.3秒以内。

13782671637

YZC51 发表于 2018-6-18 21:12
经过测试90楼代码是最快的！！！

m = Cells(n, 2).End(3).Row - 4    是不是不需要修改里边的2？