ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器,一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理,一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
123
返回列表 发新帖
楼主: 玉阳山人

[求助] 求任意三位数上下行【期】 重号个数与重号位置序号的自定义函数

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-10-23 03:15 | 显示全部楼层
本帖最后由 WYS67 于 2019-10-23 17:13 编辑

老师:今天发现下面的代码,当第三参数无论指定为0、1或2时,计算结果显示的是文本格式--指定为0,显示的是重号个数&位置序号;但当指定为1或2时,显示的是重号个数和位置序号,而这两个应该转换成数值格式,否则无法进行下一步求和或统计计算。

  恳请您于百忙中抽出时间,修改代码,使之能够在第三参数指定为1或2时,显示的计算结果为数值格式


下面是16楼和19楼【修改】确定的最后代码,请以此作蓝本进行修改--
Function CHONGHAO(rgSource As Range, intType As Integer, Optional intDisplay As Integer = 0, Optional varNum As Variant = "") As Variant
    Dim arrSource As Variant, arrResult As Variant, arrTemp As Variant, strNum As String
    Dim lngRows As Long, lngR As Long, strCur As String, strFirst As String
    Application.Volatile True
   
    lngRows = rgSource.Rows.Count
    strNum = Trim(varNum)
   
    If IsArray(rgSource) And lngRows > 1 Then
        arrSource = rgSource
    Else
        MsgBox "输入的数据源有误,请核对后重新输入!"
        Exit Function
    End If
   
    ReDim arrResult(1 To lngRows, 1 To 3) As String
   
    For lngR = LBound(arrSource) To UBound(arrSource)
        strCur = Trim(arrSource(lngR, 1))
        If lngR > LBound(arrSource) Then
            If Trim(arrSource(lngR - 1, 1)) <> "" Then strFirst = Trim(arrSource(lngR - 1, 1))
        End If
        If strNum <> "" Then strFirst = strNum
        If strCur <> "" And strFirst <> "" Then
            arrTemp = CheckStr(strFirst, strCur, intType)
            arrResult(lngR, 1) = arrTemp(1)
            arrResult(lngR, 2) = arrTemp(2)
            arrResult(lngR, 3) = arrTemp(3)
        End If
    Next
   
    Select Case intDisplay
        Case 0
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 3)
        Case 1
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 1)
        Case 2
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 2)
    End Select
   
    CHONGHAO = arrTemp
End Function




Function CheckStr(strA As String, strB As String, Optional intType As Integer = 1) As Variant
    Dim lngID As Long, lngSum As Long
    Dim strCount As Long, strAddRess As String
    Dim strFind As String, strResult() As String
   
    ReDim strResult(1 To 3) As String
    If intType <> 1 Then intType = 2 '如果不是直选,设置为组选
   
    For lngID = 1 To 3
        Select Case intType
            Case 1 '直选算法
                lngSum = lngSum + Abs((Mid(strA, lngID, 1) = Mid(strB, lngID, 1)) * 1) * (2 ^ (lngID - 1))
            Case 2 '组选算法
                strFind = Mid(strA, lngID, 1)
                lngSum = lngSum + Abs((InStr(strB, strFind) > 0) * 1) * (2 ^ (lngID - 1))
                strB = Replace(strB, strFind, "-", 1, 1)
        End Select
    Next
   
    Select Case lngSum
        Case 0 '无重复
            strCount = 0: strAddRess = 0
        Case 1 '百位相同
            strCount = 1: strAddRess = 1
        Case 2 '十位相同
            strCount = 1: strAddRess = 2
        Case 3 '百位、十位相同
            strCount = 2: strAddRess = 1
        Case 4 '个位相同
            strCount = 1: strAddRess = 3
        Case 5 '百位、个位相同
            strCount = 2: strAddRess = 3
        Case 6 '十位、个位相同
            strCount = 2: strAddRess = 2
        Case 7 '三位都相同
            strCount = 3: strAddRess = 4
    End Select
   
    strResult(1) = strCount
    strResult(2) = strAddRess
    strResult(3) = strCount & strAddRess
   
    CheckStr = strResult
End Function


TA的精华主题

TA的得分主题

发表于 2019-10-23 12:19 | 显示全部楼层
lsdongjh 发表于 2019-9-17 08:38
改一个地方就可以


老师:突然发现下面的代码,当第三参数无论指定为0、1或2时,计算结果显示的是文本格式--指定为0,显示的是重号个数&位置序号;但当指定为1或2时,显示的是重号个数和位置序号,而这两个应该转换成数值格式,否则无法进行下一步求和或统计计算。

  恳请您于百忙中抽出时间,修改代码,使之能够在第三参数指定为1或2时,显示的计算结果为数值格式。


下面是16楼和19楼【修改】确定的最后代码,请以此作蓝本进行修改--
Function CHONGHAO(rgSource As Range, intType As Integer, Optional intDisplay As Integer = 0, Optional varNum As Variant = "") As Variant
    Dim arrSource As Variant, arrResult As Variant, arrTemp As Variant, strNum As String
    Dim lngRows As Long, lngR As Long, strCur As String, strFirst As String
    Application.Volatile True
   
    lngRows = rgSource.Rows.Count
    strNum = Trim(varNum)
   
    If IsArray(rgSource) And lngRows > 1 Then
        arrSource = rgSource
    Else
        MsgBox "输入的数据源有误,请核对后重新输入!"
        Exit Function
    End If
   
    ReDim arrResult(1 To lngRows, 1 To 3) As String
   
    For lngR = LBound(arrSource) To UBound(arrSource)
        strCur = Trim(arrSource(lngR, 1))
        If lngR > LBound(arrSource) Then
            If Trim(arrSource(lngR - 1, 1)) <> "" Then strFirst = Trim(arrSource(lngR - 1, 1))
        End If
        If strNum <> "" Then strFirst = strNum
        If strCur <> "" And strFirst <> "" Then
            arrTemp = CheckStr(strFirst, strCur, intType)
            arrResult(lngR, 1) = arrTemp(1)
            arrResult(lngR, 2) = arrTemp(2)
            arrResult(lngR, 3) = arrTemp(3)
        End If
    Next
   
    Select Case intDisplay
        Case 0
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 3)
        Case 1
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 1)
        Case 2
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 2)
    End Select
   
    CHONGHAO = arrTemp
End Function




Function CheckStr(strA As String, strB As String, Optional intType As Integer = 1) As Variant
    Dim lngID As Long, lngSum As Long
    Dim strCount As Long, strAddRess As String
    Dim strFind As String, strResult() As String
   
    ReDim strResult(1 To 3) As String
    If intType <> 1 Then intType = 2 '如果不是直选,设置为组选
   
    For lngID = 1 To 3
        Select Case intType
            Case 1 '直选算法
                lngSum = lngSum + Abs((Mid(strA, lngID, 1) = Mid(strB, lngID, 1)) * 1) * (2 ^ (lngID - 1))
            Case 2 '组选算法
                strFind = Mid(strA, lngID, 1)
                lngSum = lngSum + Abs((InStr(strB, strFind) > 0) * 1) * (2 ^ (lngID - 1))
                strB = Replace(strB, strFind, "-", 1, 1)
        End Select
    Next
   
    Select Case lngSum
        Case 0 '无重复
            strCount = 0: strAddRess = 0
        Case 1 '百位相同
            strCount = 1: strAddRess = 1
        Case 2 '十位相同
            strCount = 1: strAddRess = 2
        Case 3 '百位、十位相同
            strCount = 2: strAddRess = 1
        Case 4 '个位相同
            strCount = 1: strAddRess = 3
        Case 5 '百位、个位相同
            strCount = 2: strAddRess = 3
        Case 6 '十位、个位相同
            strCount = 2: strAddRess = 2
        Case 7 '三位都相同
            strCount = 3: strAddRess = 4
    End Select
   
    strResult(1) = strCount
    strResult(2) = strAddRess
    strResult(3) = strCount & strAddRess
   
    CheckStr = strResult
End Function

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-23 16:36 | 显示全部楼层
lsdongjh 发表于 2019-9-17 08:38
改一个地方就可以

老师:恳请您以22楼代码为蓝本,修改成:当第三参数指定为1或2时,显示的计算结果为数值格式。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-23 18:06 | 显示全部楼层
老师:恳请您以22楼代码为蓝本,修改成:当第三参数指定为1或2时,显示的计算结果为数值格式。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-23 21:44 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
lsdongjh 发表于 2019-9-17 08:38
改一个地方就可以

1.gif

老师:B91:F95【粉红色填充处】无法执行统计计算。

重号与位置序号.zip (47.41 KB, 下载次数: 7)


需要修改的代码在22楼。

TA的精华主题

TA的得分主题

发表于 2019-10-24 15:00 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1.     If intDisplay <> 0 Then
  2.         For lngR = LBound(arrTemp) To UBound(arrTemp)
  3.             If arrTemp(lngR, 1) <> "" Then arrTemp(lngR, 1) = Val(arrTemp(lngR, 1))
  4.         Next
  5.     End If
复制代码


傲游截图20191024150003.png

评分

2

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-10-24 16:07 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

1.gif


大神出手,所有可能都能变成现实!

您新增添的代码已完美实现了我的初衷,再次感谢老师!

TA的精华主题

TA的得分主题

发表于 2019-11-20 14:43 | 显示全部楼层
本帖最后由 WYS67 于 2019-11-21 02:43 编辑

老师:下面这个自定义函数CHONGHAO,专门为三位数的数字而创建。但个别时候,会遇到数据区域【即第一参数】不是由三位数组成的情况,如 15,这时候的计算结果就会出现错误【无奈之下,我只能输入加上条件判断的公式 {  =IF(LEN(Y5:Y4396)=3,CHONGHAO(Y5:Y4396,2,0),"") 】。

为此,有必要在代码中增加一句代码数据区域每个单元格必须是三位数时,才可显示计算结果;如果不等于三位数,则计算结果应该屏蔽为空白!!!

    恳请老师在下面合适的地方加上这个条件判断语句。

Option Explicit


Function CHONGHAO(rgSource As Range, intType As Integer, Optional intDisplay As Integer = 0, Optional varNum As Variant = "") As Variant
    Dim arrSource As Variant, arrResult As Variant, arrTemp As Variant, strNum As String
    Dim lngRows As Long, lngR As Long, strCur As String, strFirst As String
    Application.Volatile True

    lngRows = rgSource.Rows.Count
    strNum = Trim(varNum)

    If IsArray(rgSource) And lngRows > 1 Then
        arrSource = rgSource
    Else
        MsgBox "输入的数据源有误,请核对后重新输入!"
        Exit Function
    End If

    ReDim arrResult(1 To lngRows, 1 To 3) As String

    For lngR = LBound(arrSource) To UBound(arrSource)
        strCur = Trim(arrSource(lngR, 1))
        If lngR > LBound(arrSource) Then
            If Trim(arrSource(lngR - 1, 1)) <> "" Then strFirst = Trim(arrSource(lngR - 1, 1))
        End If
        If strNum <> "" Then strFirst = strNum
        If strCur <> "" And strFirst <> "" Then
            arrTemp = CheckStr(strFirst, strCur, intType)
            arrResult(lngR, 1) = arrTemp(1)
            arrResult(lngR, 2) = arrTemp(2)
            arrResult(lngR, 3) = arrTemp(3)
        End If
    Next

    Select Case intDisplay
        Case 0
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 3)
        Case 1
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 1)
        Case 2
            arrTemp = Application.WorksheetFunction.Index(arrResult, 0, 2)
    End Select

     If intDisplay <> 0 Then
        For lngR = LBound(arrTemp) To UBound(arrTemp)
            If arrTemp(lngR, 1) <> "" Then arrTemp(lngR, 1) = Val(arrTemp(lngR, 1))
        Next
    End If
    CHONGHAO = arrTemp
End Function


Private Function CheckStr(strA As String, strB As String, Optional intType As Integer = 1) As Variant
    Dim lngID As Long, lngSum As Long
    Dim strCount As Long, strAddRess As String
    Dim strFind As String, strResult() As String

    ReDim strResult(1 To 3) As String
    If intType <> 1 Then intType = 2 '如果不是直选,设置为组选

    For lngID = 1 To 3
        Select Case intType
            Case 1 '直选算法
                lngSum = lngSum + Abs((Mid(strA, lngID, 1) = Mid(strB, lngID, 1)) * 1) * (2 ^ (lngID - 1))
            Case 2 '组选算法
                strFind = Mid(strA, lngID, 1)
                lngSum = lngSum + Abs((InStr(strB, strFind) > 0) * 1) * (2 ^ (lngID - 1))
                strB = Replace(strB, strFind, "-", 1, 1)
        End Select
    Next

    Select Case lngSum
        Case 0 '无重复
            strCount = 0: strAddRess = 0
        Case 1 '百位相同
            strCount = 1: strAddRess = 1
        Case 2 '十位相同
            strCount = 1: strAddRess = 2
        Case 3 '百位、十位相同
            strCount = 2: strAddRess = 1
        Case 4 '个位相同
            strCount = 1: strAddRess = 3
        Case 5 '百位、个位相同
            strCount = 2: strAddRess = 3
        Case 6 '十位、个位相同
            strCount = 2: strAddRess = 2
        Case 7 '三位都相同
            strCount = 3: strAddRess = 4
    End Select

    strResult(1) = strCount
    strResult(2) = strAddRess
    strResult(3) = strCount & strAddRess

    CheckStr = strResult
End Function

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-16 06:20 , Processed in 0.033416 second(s), 8 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表