Sub RefreshListBoxDate()
 Dim pt As PivotTable
 Dim pf As PivotField
 Dim iListV() As Variant
 Dim n, m, lV, lLB As Integer
 Dim s1, s2 As String Set pt = Worksheets("Свод_1").PivotTables("СводнаяТаблица2")
 Set pf = pt.PivotFields("[tbBasePLBS].[Дата].[Дата]")
 ListBox3.List = ModuleTools.Extract_Unique("tbBasePLBS", "Дата") 'Заполняем список уникальными значениями поля
 iListV = pf.VisibleItemsList lV = UBound(iListV)
 lLB = ListBox3.ListCount'Перебираем совпадения и отмечаем в списке отображаемые данные
For n = 1 To lLB
For m = 1 To lV
s1 = ModuleTools.ExtractValue(iListV(m)) 'извлекаем значение из строки фильтра и присваиваем переменной s1
s2 = ListBox3.List(n - 1)
If s1 = s2 Then ListBox3.Selected(n - 1) = True 'если значения в фильтре и списке совпали то отмечаем
Next m
Next n
End Sub

Function ExtractValue(iVal As Variant) As String
Dim iStarPos, iLenght As Integer
If iVal = Empty Then
    ExtractValue = ""
Else
    iStarPos = InStrRev(iVal, "[") + 1
    iLenght = Len(iVal) - iStarPos
    ExtractValue = Mid(iVal, iStarPos, iLenght)
End If
End Function

Function Extract_Unique(TableName, ColumnName As Variant) As Variant
    Dim vItem, avArr, li As Long
    Dim NameRange As String
    Dim myRange As Range
    
    ReDim avArr(1 To Rows.Count)
    
    NameRange = TableName & "[" & ColumnName & "]" 'формируем имя диапазона искомого столбца в заданой таблице
    Set myRange = Range(NameRange) 'присваиваем переменной искомый диапазон
         
    
    With New Collection
        On Error Resume Next
        For Each vItem In myRange.Value
            'Cells(Rows.Count, 1).End(xlUp) – определяет последнюю заполненную ячейку в столбце А
            .Add vItem, CStr(vItem)
            If Err = 0 Then
                li = li + 1: avArr(li) = vItem
            Else: Err.Clear
            End If
        Next
    End With
    ReDim Preserve avArr(1 To li)
    If li Then Extract_Unique = avArr
End Function