Только отфильтрованные / видимые данные VBA - PullRequest
Новая
       25

Только отфильтрованные / видимые данные VBA

0 голосов
/ 05 декабря 2018

У меня есть сценарий VBA, который был очень любезно предоставлен другим участником .

С момента обращения за помощью я понял, что мне нужно суммировать только данные в видимых ячейках как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

Большое спасибо за любую помощь заранее

1 Ответ

0 голосов
/ 12 декабря 2018

Спасибо Михалу и пользователю 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
...