VBA自定义函数QTDE多条件求和异常，请求修正逻辑

需求说明 #

在(ACOES) VALORES工作表的QTDE列使用公式=QTDE([@ACÃO])，需要实现：

• 筛选EXTRATO工作表中EXTRATO列表对象里，TIPO列值为COMPRA、BONIFICACAO或SUBSCRICAO的行
• 匹配这些行中ATIVO列值与当前行[@ACÃO]一致的记录
• 对符合条件的行的QTDE列数值求和

当前函数计算结果异常，仅累加部分目标行，得到结果24，不符合预期。

错误代码 #

Function QTDE(acao As String) As Double
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim cel As Range
    Dim tipoCol As ListColumn
    Dim ativoCol As ListColumn
    Dim qtdeCol As ListColumn
    Dim totalQtde As Double
    
    Set ws = ThisWorkbook.Sheets("EXTRATO")
    Set tbl = ws.ListObjects("EXTRATO")
    
    Set tipoCol = tbl.ListColumns("TIPO")
    Set ativoCol = tbl.ListColumns("ATIVO")
    Set qtdeCol = tbl.ListColumns("QTDE")
    
    For Each cel In tipoCol.DataBodyRange
        If (cel.Value = "COMPRA" Or cel.Value = "BONIFICACAO" Or cel.Value = "SUBSCRICAO") And ativoCol.DataBodyRange(cel.Row).Value = acao Then
            totalQtde = totalQtde + qtdeCol.DataBodyRange.Cells(cel.Row).Value
        End If
    Next cel
    
    QTDE = totalQtde
End Function

问题根源 #

代码中使用工作表行号cel.Row引用列表对象的列数据范围是错误的：

• 列表对象的DataBodyRange是相对自身的区域，其行索引从1开始（对应列表的第一行数据），而非工作表的行号
• 比如列表对象从工作表第3行开始，cel.Row返回工作表行号3，但ativoCol.DataBodyRange(cel.Row)会试图访问列表数据区域的第3行，实际列表第1行对应工作表第3行，导致索引越界或引用错误的行，最终只累加了部分符合条件的记录

修正方案 #

方案1：遍历ListRow对象（推荐） #

直接遍历列表的ListRow对象，通过列索引获取对应单元格值，逻辑更清晰：

Function QTDE(acao As String) As Double
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim row As ListRow
    Dim totalQtde As Double
    
    Set ws = ThisWorkbook.Sheets("EXTRATO")
    Set tbl = ws.ListObjects("EXTRATO")
    
    For Each row In tbl.ListRows
        Select Case row.Range(tbl.ListColumns("TIPO").Index).Value
            Case "COMPRA", "BONIFICACAO", "SUBSCRICAO"
                If row.Range(tbl.ListColumns("ATIVO").Index).Value = acao Then
                    totalQtde = totalQtde + row.Range(tbl.ListColumns("QTDE").Index).Value
                End If
        End Select
    Next row
    
    QTDE = totalQtde
End Function

方案2：修正相对行号计算 #

保留原遍历思路，计算列表内的相对行号，修正行号引用错误：

Function QTDE(acao As String) As Double
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim cel As Range
    Dim tipoCol As ListColumn
    Dim ativoCol As ListColumn
    Dim qtdeCol As ListColumn
    Dim totalQtde As Double
    Dim rowIndex As Long
    
    Set ws = ThisWorkbook.Sheets("EXTRATO")
    Set tbl = ws.ListObjects("EXTRATO")
    
    Set tipoCol = tbl.ListColumns("TIPO")
    Set ativoCol = tbl.ListColumns("ATIVO")
    Set qtdeCol = tbl.ListColumns("QTDE")
    
    For Each cel In tipoCol.DataBodyRange
        ' 计算列表数据区域内的相对行号
        rowIndex = cel.Row - tbl.DataBodyRange.Row + 1
        If (cel.Value = "COMPRA" Or cel.Value = "BONIFICACAO" Or cel.Value = "SUBSCRICAO") And _
           ativoCol.DataBodyRange(rowIndex).Value = acao Then
            totalQtde = totalQtde + qtdeCol.DataBodyRange(rowIndex).Value
        End If
    Next cel
    
    QTDE = totalQtde
End Function

内容的提问来源于stack exchange，提问作者Cooper