仅对过滤/可见数据求和 VBA

Posted 2023-05-08

【中文标题】仅对过滤/可见数据求和 VBA

【英文标题】：Sum Filtered/Visible Data only VBA

【发布时间】：2018-12-05 03:19:17

【问题描述】：

我有一个非常友好的 VBA 脚本provided by another member。

自从请求帮助后，我意识到我需要像 SUBTOTAL 函数那样只对可见单元格中的数据求和（例如，如果应用了过滤器）。我试图插入xlCellTypeVisible，但运气不佳（VBA 还是新手！）。这个宏背后的上下文可以通过阅读上面链接中的线程找到。

谁能帮忙写出正确的代码？

 Function maxUniqueWithThresholda(ids As Range, vals As Range, _
                                 dates As Range, thold As Long)
     Static d As Object, i As Long

     'create a dictionary for unique ids only if not previously created
     If d Is Nothing Then Set d = CreateObject("scripting.dictionary")
     d.RemoveAll

     'limit the processing ranges
     Set ids = Intersect(ids, ids.Parent.UsedRange)
     Set vals = vals.Resize(ids.Rows.Count, ids.Columns.Count)
     Set dates = dates.Resize(ids.Rows.Count, ids.Columns.Count)

     'cycle through the processing ranges
     For i = 1 To ids.Cells.Count
         'is date within threshold?
         If dates.Cells(i) <= thold And xlCellTypeVisible Then
             'collect the maximum value for each unique id into dictionary Items
             d.Item(ids.Cells(i).Value2) = _
               Application.Max(d.Item(ids.Cells(i).Value2), vals.Cells(i).Value2)
         End If
     Next i

     maxUniqueWithThresholda = Application.Sum(d.items)

 End Function

非常感谢您提前提供的任何帮助

【问题讨论】：

如果 dates.Cells(i)

@MichalRosa - 您不必将布尔值与布尔常量进行比较来确定布尔结果。 ... And Not dates.Cells(i).EntireRow.Hidden 应该足够了。 （注意 i 不是 1）

【参考方案1】：

感谢 Michal 和用户 10735198 的输入：

Function maxUniqueWithThresholda(ids As Range, vals As Range, _
                            dates As Range, thold As Long)
Static d As Object, i As Long

'create a dictionary for unique ids only if not previously created
If d Is Nothing Then Set d = CreateObject("scripting.dictionary")
d.RemoveAll

'limit the processing ranges
Set ids = Intersect(ids, ids.Parent.UsedRange)
Set vals = vals.Resize(ids.Rows.Count, ids.Columns.Count)
Set dates = dates.Resize(ids.Rows.Count, ids.Columns.Count)

'cycle through the processing ranges
For i = 1 To ids.Cells.Count
    'is date within threshold?
    If dates.Cells(i) <= thold And dates.Cells(i).EntireRow.Hidden = False Then
        'collect the maximum value for each unique id into dictionary Items
        d.Item(ids.Cells(i).Value2) = _
          Application.Max(d.Item(ids.Cells(i).Value2), vals.Cells(i).Value2)
    End If
Next i

maxUniqueWithThresholda = Application.Sum(d.items)

End Function