重新编写自定义函数冷码和冷号的代码

WYS67

lss001 发表于 2018-10-7 14:35
Function WEN_LEN(rng As Range, x)
    Dim ar, br, cr, i, j, k '1温码2冷码
    ar = rng: ReDim br(1 ...

正在测试，表一没有问题，符合要求。稍后给您反馈测试结果。

WYS67

lss001 发表于 2018-10-7 14:35
Function WEN_LEN(rng As Range, x)
    Dim ar, br, cr, i, j, k '1温码2冷码
    ar = rng: ReDim br(1 ...

表一：1.如果公式输入的区域C5:C100000]比数据区域【B5:46984】大，没有数据的C46985:C100000显示的0不合题意，也容易和一位数冷码的0混淆，应该屏蔽为空白才对。
          2.表一数据区域B5:B46984中间虽然没有空格，但计算规则和表二的第2项一样。

表二：1.《一位数冷号》的C列是数据源，D列是冷号计算结果的模拟答案，E列是用LENGHAO代码计算的冷号，但用您写的代码{ =WEN_LEN(C5:C100000,2)计算出的结果和D、E列不一样。
   一位数冷号和两位数冷码个位数的运算规则完全相同，只是没有十位数而已。
         2.数据源中间如果有空格，同一行上的计算结果也应显示为空格，但下一行冷码的计算只按0、1、2作比较，作忽略空格处理，您仔细看看表二D列的模拟结果就会明白。

lss001

楼上已经更新！！！

WYS67

lss001 发表于 2018-10-7 14:35
Function WEN_LEN(rng As Range, x)
    Dim ar, br, cr, i, j, k 'x=1温x=2冷
    ar = rng: ReDim br(1 ...

老师：经过一上午测试，您所写代码的运算规则完全正确！运算速度和原来比较就犹如云泥之别，简直不可同日而论！特别是您把原先需要各自运算的函数合二为一的举措，使我对VBA自定义函数功能强大的认识又进了一步！



上面截图：A列是数据源。B列是热码【即当期数据】，C:D列是用您写的代码求出结果的温码和冷码。
从截图可以看出热温冷码之间有以下关系【如果是两位数，则十、个位需要分别计算】：热码+温码+冷码=33
1.冷码=33-热码-温码；
2.温码=33-热码-冷码；
3.热码=33-温码-冷码=当期数据

掌握了这些规律，并编写进代码里，就可以使代码的运算效率更高！

    谢谢老师这一段对我的耐心帮忙！青山不改，绿水长流！

lss001

Function WEN_LEN(rng As Range, x)
    Dim ar, br, cr, i, j, k, y 'x=1温x=2冷
    ar = rng: ReDim br(1 To UBound(ar), 1 To 2)
    ReDim cr(1 To UBound(ar), 0)
    Set d = CreateObject("scripting.dictionary")
    Set b = CreateObject("scripting.dictionary")
    For k = UBound(ar) To 1 Step -1
        If ar(k, 1) <> "" Then Exit For
        cr(k, 0) = ""
    Next
    If Len(ar(k, 1)) = 2 Then y = 2
    For i = 1 To k
        br(i, 1) = Mid(ar(i, 1), 1, 1)
        If y = 2 Then br(i, 2) = Mid(ar(i, 1), 2, 1)
        If i > 1 Then
        d.RemoveAll
        For j = i To 1 Step -1
            If br(j, 1) <> "" Then d(br(j, 1)) = ""
            If d.Count = 2 Then Exit For
        Next
        If y = 2 Then
            b.RemoveAll
            For j = i To 1 Step -1
                If br(j, 1) <> "" Then b(br(j, 2)) = ""
                If b.Count = 2 Then Exit For
            Next
            If x = 1 And d.Count > 1 And b.Count > 1 Then cr(i, 0) = d.keys()(1) & b.keys()(1)
            If x = 2 And d.Count > 1 And b.Count > 1 Then cr(i, 0) = _
            (3 - d.keys()(0) - d.keys()(1)) & (3 - b.keys()(0) - b.keys()(1))
        Else
            If x = 1 And d.Count > 1 Then cr(i, 0) = d.keys()(1)
            If x = 2 And d.Count > 1 Then cr(i, 0) = 3 - d.keys()(0) - d.keys()(1)
        End If
            If d.Count < 2 Or br(i, 1) = "" Then cr(i, 0) = ""
            If y = 2 And b.Count < 2 Then cr(i, 0) = ""
        End If
    Next
    cr(1, 0) = "": WEN_LEN = cr
End Function

WYS67

lss001 发表于 2018-10-8 15:57
根据您的建议，速度有提高！

Function WEN_LEN(rng As Range, x)

刚从外边回来，复制代码测试中。

WYS67

lss001 发表于 2018-10-8 15:57
根据您的建议，速度有提高！

Function WEN_LEN(rng As Range, x)

嗯！原先的速度虽然够快，但按下数据确定公式时，总有一种迟滞、微微卡顿的感觉，现在觉得从确定到显示结果的用时，有所加快！

原先的模式，温码冷码两个都得查询，现在只要查询一个温码，然后套用公式：冷码=3-热码【当期数据】-温码就行了！ 按指定条件查询，变成了简单的减法公式，速度肯定会有提升的！

WYS67

lss001 发表于 2018-10-8 18:54
上楼按您的建议简化代码！
即去掉冷码，只保留温码
这样温码公式不需要第二参数

老师辛苦了！是我的语言表述能力有限，造成您理解差池，费事多写了这个代码。其实我是评价上次代码速度快的！上次的代码完全实现了我心中的想法【温码和冷码俱全，一个函数全部搞定】。
   这次速度更快，却不能和上次一样：指定C4为1【温码】，D4为2【冷码】，在C5:C100000里输入
{ =WENLENG($A$5:$A$100000,C4)，右拉至D列，便能显示温码和冷码。

这几天有劳您太多了！心下很是不安。所以我决定还是把上次代码加载宏【用途广】，谢谢您！祝您身心愉快！

lss001

根据您的描述
要加载宏建议用楼上最近更新
就按以前增加第二参数

WYS67

lss001 发表于 2018-10-8 20:03
根据您的描述
要加载宏建议用楼上最近更新
就按以前增加第二参数

已测试，两位数计算结果显示正确，一位数全部空白。