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

13782671637

YZC51 发表于 2018-6-18 07:54
已经修改
Sub 冷码()
    Dim brr(), sr()

老师：如果我要变更数据源和计算结果列标和指定截止行号三项内容，只需要改动下面红色标注的3个地方吗？

Sub 冷码()
    Dim brr(), sr()
    tms = Timer
    m = [a1] - 4 'Cells(Rows.Count, 1).End(3).Row - 4
    ar = [a5].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)
        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
    [b5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

13782671637

YZC51 发表于 2018-6-18 07:54
已经修改
Sub 冷码()
    Dim brr(), sr()

老师：麻烦您解释一下 m = [a1] - 4 'Cells(Rows.Count, 1).End(3).Row - 4  是什么意思？是指C2单元格吗？如果我要把指定截止行号放在D3里，应该怎么修改？

YZC51

13782671637 发表于 2018-6-18 08:46
老师：麻烦您解释一下 m = [a1] - 4 'Cells(Rows.Count, 1).End(3).Row - 4  是什么意思？是指C2单元格吗 ...

m = [a1] - 4
[a1]:公式计算出的数据A列的总行数；减4是从第五行开始。

ar = [a5].Resize(m)
是将A列第五行开始m行数据，存入数组ar

[b5].Resize(m) = sr
是从B列第五行开始存放计算结果

13782671637

13782671637 发表于 2018-6-18 08:15
老师：如果我要变更数据源和计算结果列标和指定截止行号三项内容，只需要改动下面红色标注的3个地方吗？
...

老师：指定截止行号的单元格是C2，而不是A1。代码运行错误

13782671637

13782671637 发表于 2018-6-18 08:15
老师：如果我要变更数据源和计算结果列标和指定截止行号三项内容，只需要改动下面红色标注的3个地方吗？
...

限定代码的计算和显示区域.zip (315.78 KB, 下载次数: 2)

2018-6-18 09:23 上传

点击文件名下载附件

YZC51

实际数据行数要少于截止数据行数！

YZC51

13782671637 发表于 2018-6-18 09:24

请参考
Sub 冷码()
    Dim brr(), sr()
    tms = Timer
    n = [c2]  '
    Debug.Print n
'    m = Cells(Rows.Count, 1).End(3).Row - 4
    m = Cells(n, 1).End(3).Row - 4
    Debug.Print m
    If m = 0 Then m = n - 4
    ar = [a5].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 Resume Next
        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
    [b5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

13782671637

YZC51 发表于 2018-6-18 11:14
请参考
Sub 冷码()
    Dim brr(), sr()

这次代码非常完美地实现了我预想！结果正确，速度很快! 感谢YZC51老师的热心帮忙!

13782671637

YZC51 发表于 2018-6-18 11:14
请参考
Sub 冷码()
    Dim brr(), sr()

老师：学生愚鲁，代码【已修改过数据源和结果列标】复制粘贴进实际工作表后，出现如下面截图错误，请看附件： 什么原因？.zip (615.88 KB, 下载次数: 2)

2018-6-18 19:05 上传

点击文件名下载附件

13782671637

YZC51 发表于 2018-6-18 11:14
请参考
Sub 冷码()
    Dim brr(), sr()

老师：是不是代码无法计算文本类数字？为什么下面蓝桥玄霜版主的代码能显示正确结果呢？Sub 冷码1()
    Dim brr(), sr()
    tms = Timer
    m = [c2].Value - 4
    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
        If ar(i - 1, 1) <> "" Then t = ar(i - 1, 1): t11 = Left(t, 1): t12 = Right(t, 1)
        If ar(i, 1) <> "" Then
        t = ar(i, 1): t21 = Left(t, 1): t22 = Right(t, 1)
        If t11 = t21 Then s1 = Left(s, 1) Else s1 = 3 - Val(t11) - Val(t21)
        If t12 = t22 Then s2 = Right(s, 1) Else s2 = 3 - Val(t12) - Val(t22)
        s = s1 & s2
        sr(i, 1) = s
        End If
    Next
    [c5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub