w_DicFiltersPt_Date

'##### Словарь дат для сводной

Function FnDicFilterDate(ByVal strDate As String) As Variant ', _

'strDate - интервал дат строкой (01.01.2017-11.01.2017)

Dim oPf As PivotField 'поле

Dim oPi As PivotItem 'элементы поля

Dim strPi As String

Dim m As Variant, aPi As Variant 'временные массивы

Dim FnDicPi As Object 'словарь дат

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set FnDicPi = CreateObject("scripting.dictionary"): FnDicPi.comparemode = 1

'словарь дат

If Len(strDate) = 0 Then 'если интервал не задан(для сброса фильтра)

Set FnDicFilterDate = FnDicPi

' FnDicFilterDate = ""

Exit Function

Else

m = Split(strDate, " - ", -1, vbTextCompare)

Dim dDateStart As Date: dDateStart = m(LBound(m))

Dim dDateEnd As Date: dDateEnd = m(UBound(m))

Dim dValue As Date: dValue = dDateStart

Erase m

If dDateStart > dDateEnd Then

MsgBox "Некорректные даты!", 48, "Внимание!"

' Exit Function

End If

If dDateStart = dDateEnd Then

strPi = dDateStart

' strPi = FnDateStrPi_RU_EN(dDateStart)

FnDicPi.Add strPi, strPi

Set FnDicFilterDate = FnDicPi

Exit Function

End If

ReDim aPi(0)

i = 0

Do While dValue <= dDateEnd

ReDim Preserve aPi(i)

aPi(i) = FnDateStrPi_RU_EN(dValue)

dValue = dValue + 1

i = i + 1

Loop

' If TypeName(DictPi) = "String" Then

'словарь элементов для фильтра

' Set FnDicPi = CreateObject("scripting.dictionary"): FnDicPi.comparemode = 1

For j = LBound(aPi) To UBound(aPi)

strPi = aPi(j)

If Not FnDicPi.exists(strPi) Then FnDicPi.Add strPi, strPi

Next 'j

End If

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set FnDicFilterDate = FnDicPi

End Function

'### Преобразует дату в басурманский формат

Function FnDateStrPi_RU_EN(ByVal strDateValue As String) As String

Dim m As Variant

m = Split(strDateValue, ".", -1, vbBinaryCompare)

If Left(m(0), 1) = 0 Then m(0) = Right(m(0), Len(m(0) - 1))

If Left(m(1), 1) = 0 Then m(1) = Right(m(1), Len(m(1) - 1))

FnDateStrPi_RU_EN = m(1) & "/" & m(0) & "/" & m(2)

End Function

'### Преобразует дату из басурманского формата

Function FnDateStrPi_EN_RU(ByVal strDateValue As String) As String

Dim m As Variant

m = Split(strDateValue, "/", -1, vbBinaryCompare)

If Len(m(0)) = 1 Then m(0) = "0" & m(0)

If Len(m(1)) = 1 Then m(1) = "0" & m(1)

FnDateStrPi_EN_RU = m(1) & "." & m(0) & "." & m(2)

End Function

w_DicFiltersPt_String

'##### Словарь элементов для сводной

Function FnDicFilterString(ByVal strItems As String) As Variant

Dim oPf As PivotField 'поле

Dim oPi As PivotItem 'элементы поля

Dim m As Variant, aPi As Variant 'временные массивы

Dim FnDicPi As Object 'словарь элементов

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Set FnDicPi = CreateObject("scripting.dictionary"): FnDicPi.comparemode = 1

'словарь дат

If Len(strItems) = 0 Then 'если интервал не задан(для сброса фильтра)

Set FnDicFilterString = FnDicPi

Exit Function

Else

aPi = Split(strItems, ", ", -1, vbTextCompare)

' ReDim aPi(0)

If IsArray(aPi) Then 'если массив, то перебираем

For j = LBound(aPi) To UBound(aPi)

'если коды, то проверяем на "0"

If InStr(1, strPf, "Код", vbTextCompare) Or _

InStr(1, strPf, "Code", vbTextCompare) Then

strPi = FnCodeStrPi(Trim(aPi(j)))

Else

strPi = Trim(aPi(j))

End If

'словарь элементов для фильтра

If Not FnDicPi.exists(strPi) Then FnDicPi.Add strPi, strPi

Next 'j

Else 'если один элемент

strPi = Trim(strItems)

FnDicPi.Add strPi, strPi

End If

End If

Set FnDicFilterString = FnDicPi

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

'EventsChange False

'EventsChange True

End Function

'##### 'если коды, то проверяем на "0"

Function FnCodeStrPi(ByVal strPi As String) As String

If Len(strPi) = 3 Then FnCodeStrPi = "0" & strPi

If Len(strPi) = 2 Then FnCodeStrPi = "00" & strPi

If Len(strPi) = 1 Then FnCodeStrPi = "000" & strPi

End Function