能够按指定行号、列标，动态扩展统计区域的内嵌自定义函数

玉阳山人

lsdongjh 发表于 2019-11-11 13:45

------------------------------------------------------

玉阳山人

lsdongjh 发表于 2019-11-12 08:55
1、要有一些基本常识，字符型 与 数值型【DTQY("J","Q")】
2、原来考虑是简单的处理，返回的是数组，给你 ...

能够自动刷新的动态区域.zip (61.13 KB, 下载次数: 0)

2020-3-15 17:50 上传

点击文件名下载附件

老师：经过两天来的反复测试，终于找到了DTQY原代码出现错误的根源。当实际上的数据区域，小于第1~3参数指定的范围时，计算的结果都正确！唯独只在   数据区域=指定范围    情况下才会出错。

那么，只需再增加一个判断语句：当数据区域的最后行、列与参数2指定的范围相同时，则用指定范围代替数据区域，进行统计计算就行了吧？     如：T5:T22中指定范围是DTQY("J","Q",,,1），代表对J:Q列里的各行数据进行统计，从上图看出，指定范围的最后一列Q5:Q22里，哪一行若没有数据，则T5:T22的哪一行计算结果就正确；哪一行有数据，T5:T22的哪一行计算结果就不对。

   模块1的代码里，If intAll <> 0 Then SelRow_End = SelSh.Cells(SelRow_End, lngCurCol).End(xlUp).Row  这一句好像是代表最后数据行；而  If intAll <> 0 Then SelCol_End = SelSh.Cells(lngCurRow, SelCol_End).End(xlToLeft).Column 则是代表最后数据列；

麻烦老师在这两句后面增加判断代码---当数据区域正好等于指定范围时，则用指定范围代替数据区域进行统计计算，这样就能保证计算结果始终正确了！


代码如下：


Function DTQY(StartID As Variant, EndID As Variant, Optional RowOrColID As Variant = "", Optional shName As String = "", Optional intAll As Integer = 0) As Variant
    Application.Volatile '声明为易失性函数
    Dim rgCur As Range, strRowOrColID As String, strSelType As String
    Dim lngCurRow As Long, lngCurCol As Long
    Dim SelRow_Start As Long, SelRow_End As Long
    Dim SelCol_Start As Long, SelCol_End As Long
    Dim SelSh As Worksheet, arrResult As Variant

    '取得公式所在单元格的信息
    Set rgCur = Application.Caller
    lngCurRow = rgCur.Row
    lngCurCol = rgCur.Column
    '获取工作表
    If Trim(shName) = "" Then
        Set SelSh = rgCur.Worksheet
    Else
        Set SelSh = GetShByName(Trim(shName))
    End If
    If SelSh Is Nothing Then
        DTQY = "表名不存在"
        Exit Function
    End If

    '判断参数类型
    If IsNumeric(StartID) Then
        strSelType = "ROW"
    Else
        strSelType = "COL"
    End If
    '如果参数1与参数2类型不一致，退出
    If IsNumeric(StartID) <> IsNumeric(EndID) Then
        DTQY = "参数1、2类型不一致"
        Exit Function
    End If
    '如果参数1、2的类型与参数3相同，退出
    If RowOrColID <> "" And (IsNumeric(StartID) = IsNumeric(RowOrColID)) Then
        DTQY = "参数3类型不对"
        Exit Function
    End If

    '如果行号参数不对，退出
    If IsNumeric(StartID) And (Val(StartID) < 1 Or Val(StartID) > Rows.Count) Then
        DTQY = "参数1设置有误"
        Exit Function
    End If
    If IsNumeric(EndID) And (Val(EndID) < 1 Or Val(EndID) > Rows.Count) Then
        DTQY = "参数2设置有误"
        Exit Function
    End If

    '设置第三参数
    strRowOrColID = Trim(UCase(RowOrColID))
    '根据传入的参数，设置区域参数
    Select Case strSelType
        Case "ROW" '设置参数为行号
            SelRow_Start = Val(StartID) '起始行
            SelRow_End = Val(EndID) '结束行
            '根据第三参数获取列号
            If strRowOrColID <> "" Then
                lngCurCol = GetColIDByStr(strRowOrColID)
            End If
            '列号有误，退出
            If lngCurCol = 0 Then
                DTQY = "参数3设置有误"
                Exit Function
            End If

            If intAll <> 0 Then SelRow_End = SelSh.Cells(SelRow_End, lngCurCol).End(xlUp).Row

            '返回选择区域
            Set arrResult = SelSh.Range(SelSh.Cells(SelRow_Start, lngCurCol), SelSh.Cells(SelRow_End, lngCurCol))
        Case "COL" '设置参数为列号
            SelCol_Start = GetColIDByStr(CStr(StartID)) '起始列
            SelCol_End = GetColIDByStr(CStr(EndID)) '结束列
            If SelCol_Start * SelCol_End = 0 Then
                DTQY = "参数1、2设置有误"
                Exit Function
            End If
            '根据第三参数获取行号
            If strRowOrColID <> "" Then
                lngCurRow = Val(strRowOrColID)
            End If
            '行号有误，退出
            If lngCurRow < 1 Or lngCurRow > Rows.Count Then
                DTQY = "参数3设置有误"
                Exit Function
            End If


            If intAll <> 0 Then SelCol_End = SelSh.Cells(lngCurRow, SelCol_End).End(xlToLeft).Column
            '返回选择区域
            Set arrResult = SelSh.Range(SelSh.Cells(lngCurRow, SelCol_Start), SelSh.Cells(lngCurRow, SelCol_End))
    End Select

    '返回最终结果区域
    Set DTQY = arrResult
End Function

'根据列名，返回列标索引
Private Function GetColIDByStr(strColName As String) As Long
    Dim strAddress  As String, lngLen As Long
    Dim lngIndex As Long, strChar As String
    Dim lngColID As Long

    strAddress = Trim(UCase(strColName))
    lngLen = Len(strAddress)

    For lngIndex = 1 To lngLen
        strChar = Mid(strAddress, lngIndex, 1)
        If Asc(strChar) < 65 Or Asc(strChar) > 90 Then
            GetColIDByStr = 0
            Exit Function
        End If
        lngColID = lngColID + (((Asc(strChar) - 65) Mod 26) + 1) * (26 ^ (lngLen - lngIndex))
    Next

    If lngColID > Columns.Count Then
        GetColIDByStr = 0
        Exit Function
    End If

    GetColIDByStr = lngColID
End Function

'根据表名返回工作表
Private Function GetShByName(strShName As String) As Worksheet
    Dim sh As Worksheet
    For Each sh In Sheets
        If sh.Name = strShName Then
            Set GetShByName = sh
            Exit Function
        End If
    Next
    Set GetShByName = Nothing
End Function