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

13782671637

zopey 发表于 2018-6-15 18:24
被你 “=3-十位第一个数-十位第二个数&3-个位第一个数-个位第二个数” 的 规则 误导了：
去求 k1=2， k2=2 ...

恳请老师帮忙！

zopey

Sub test2()
tms = Timer
Columns("d:d").ClearContents
Dim arr, k0, brr(), crr()

k0 = [b5].End(4).Row - 4
arr = [b5].Resize(k0, 1)
ReDim crr(1 To k0, 1 To 1)

For i = 1 To k0
    ReDim brr(0 To 2)
    t0 = Left(arr(i, 1), 1): k1 = 0
    For j = i To 1 Step -1
        t1 = Left(arr(j, 1), 1): brr(t1) = brr(t1) + 1: If brr(t1) = 1 Then k1 = k1 + 1
        If k1 = 2 Then crr(i, 1) = "'" & (3 - t0 - t1): Exit For
    Next

    ReDim brr(0 To 2)
    t0 = Right(arr(i, 1), 1): k2 = 0
    For j = i To 1 Step -1
        t2 = Right(arr(j, 1), 1): brr(t2) = brr(t2) + 1: If brr(t2) = 1 Then k2 = k2 + 1
        If k2 = 2 Then crr(i, 1) = crr(i, 1) & (3 - t0 - t2): Exit For
    Next

    If k1 = 1 Or k2 = 1 Then crr(i, 1) = ""
Next

[d5].Resize(k0, 1) = crr
MsgBox Format(Timer - tms, "0.000s")
End Sub


Book2.rar (383.6 KB, 下载次数: 12)

2018-6-16 09:03 上传

点击文件名下载附件

zopey

'4楼代码 添加补充规则

Sub test()
    Dim brr(), sr()
    tms = Timer
    m = Cells(Rows.Count, 2).End(3).Row - 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
        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
    [c5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

13782671637

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

Sub test()

非常感谢老师的倾心付出！测试后结果显示正确，计算速度很快！53楼的代码Sub test()
    Dim brr(), sr()
    tms = Timer
    m = Cells(Rows.Count, 2).End(3).Row - 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
        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
    [.Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub
如果要修改数据源和代码计算列，是不是只需修改代码第五行的b5和倒数第三行的c5就可以了？

13782671637

zopey 发表于 2018-6-16 09:04
Sub test2()
tms = Timer
Columns("d:d").ClearContents

Sub test2()
tms = Timer
Columns("d:d").ClearContents
Dim arr, k0, brr(), crr()

k0 = [b5].End(4).Row - 4
arr = [b5].Resize(k0, 1)
ReDim crr(1 To k0, 1 To 1)

For i = 1 To k0
    ReDim brr(0 To 2)
    t0 = Left(arr(i, 1), 1): k1 = 0
    For j = i To 1 Step -1
        t1 = Left(arr(j, 1), 1): brr(t1) = brr(t1) + 1: If brr(t1) = 1 Then k1 = k1 + 1
        If k1 = 2 Then crr(i, 1) = "'" & (3 - t0 - t1): Exit For
    Next

    ReDim brr(0 To 2)
    t0 = Right(arr(i, 1), 1): k2 = 0
    For j = i To 1 Step -1
        t2 = Right(arr(j, 1), 1): brr(t2) = brr(t2) + 1: If brr(t2) = 1 Then k2 = k2 + 1
        If k2 = 2 Then crr(i, 1) = crr(i, 1) & (3 - t0 - t2): Exit For
    Next

    If k1 = 1 Or k2 = 1 Then crr(i, 1) = ""
Next

[d5].Resize(k0, 1) = crr
MsgBox Format(Timer - tms, "0.000s")
End Sub老师：如果要修改数据源，是不是和公式所在列是不是只需修改第三行的d:d，第五、六行的b5,倒数第三行的d5就可以了？

zopey

m = Cells(Rows.Count, 2).End(3).Row - 4

k0 = [b5].End(4).Row - 4   跟这个差不多哦，

都是 读取数据列 共有多少行

13782671637

zopey 发表于 2018-6-16 10:30
m = Cells(Rows.Count, 2).End(3).Row - 4

k0 = .End(4).Row - 4   跟这个差不多哦，

老师：以53楼为例：如果数据源在K列，公式在N列，需要修改以下：Sub test()
    Dim brr(), sr()
    tms = Timer
    m = Cells(Rows.Count, 11).End(3).Row - 4  
    ar = [k5].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
    [n5].Resize(m) = sr
    MsgBox Format(Timer - tms, "0.000s")
End Sub

lsc900707

13782671637 发表于 2018-6-16 10:39
老师：以53楼为例：如果数据源在K列，公式在N列，需要修改以下：Sub test()
    Dim brr(), sr()
    t ...

   m = Cells(Rows.Count, 11).End(3).Row - 4   

13782671637

lsc900707 发表于 2018-6-16 10:46
m = Cells(Rows.Count, 11).End(3).Row - 4   这行怎么修改？

版主老师：我问的是这行需不需要修改？

lsc900707

13782671637 发表于 2018-6-16 10:49
版主老师：我问的是这行需不需要修改？

m = Cells(Rows.Count, 2).End(3).Row - 4  
修改成：
m = Cells(Rows.Count, 11).End(3).Row - 4