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

YZC51

13782671637 发表于 2018-6-16 18:29
恳请高手大神们帮忙看看65楼附件里的问题怎么解决？

楼主好！
不要太执着！给你个可调节数据列和输出列的过程，将就着用吧！
此过程是在Zopey老师的代码基础上稍作修改而成！在此谢谢老师！
说实在的：你这样的问题不适合用自定义函数解决，不然数据量一大就会卡机！

YZC51

请参考！更要珍惜论坛资源，请不要太执着！！！
为C列自定义函数的代码计算提速-.rar (563.84 KB, 下载次数: 11)

2018-6-16 18:48 上传

点击文件名下载附件

13782671637

YZC51 发表于 2018-6-16 18:48
请参考！更要珍惜论坛资源，请不要太执着！！！

感谢老师帮助。代码运行很快！

13782671637

lsc900707 发表于 2018-6-16 10:53
m = Cells(Rows.Count, 2).End(3).Row - 4  
修改成：
m = Cells(Rows.Count, 11).End(3).Row - 4

感谢版主的热心帮忙！

13782671637

zopey 发表于 2018-6-16 09:07
'4楼代码 添加补充规则

Sub test()

老师：53楼经您修改的代码计算结果正确，运行速度飞快！爽爆了！由于实际工作表的C2限定了A列数据源的区域范围【因为C2指定的行号下方，需要进行各列的统计计算】，如附件 冷码 zopey 过程 20180618.zip (313.87 KB, 下载次数: 6)

2018-6-18 03:50 上传

点击文件名下载附件

所示：当C2=46984时，代表只能计算A5:A46984范围内的数据，B列计算结果最多显示到B5:B46984行为止，而不能影响A46985:B46985及下方区域的其它统计计算结果。所以，还得麻烦您对E5:E39的代码加以修改和完善，增加以C2指定的行号为代码计算的下止点。

YZC51

13782671637 发表于 2018-6-18 04:03
老师：53楼经您修改的代码计算结果正确，运行速度飞快！爽爆了！由于实际工作表的C2限定了A列数据源的区 ...

请参考
Sub 冷码()
    Dim brr(), sr()
    tms = Timer
    m = [c2] + 1 '- 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 - 5
        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:40
请参考
Sub 冷码()
    Dim brr(), sr()

老师：点击按钮后显示错误：

YZC51

已经修改
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

YZC51

建议：统计行放在A3、B3为好！

13782671637

YZC51 发表于 2018-6-18 07:57
建议：统计行放在A3、B3为好！

老师：统计内容有好多项；是与其它列的统计项目并存于下方的。谢谢老师把热情帮忙！