'=======================================================================
'// 'формируем строку для интервала дат в 12 месяцев
Sub strDate_12()
Dim i_PrevMonth As Integer: i_PrevMonth = 0 'месяц -1
Dim iLastDay As Integer
Dim DicDate As Variant
'iLastDay = Day(DateSerial(2010, 5, 1) - 1)
iLastDay = Day(DateSerial(Year(Now), Month(Now) - i_PrevMonth, 1) - 1)
strDateStart = Format(1 & "." & Month(Now) - i_PrevMonth & "." & Year(Now) - 1, "DD.MM.YYYY")
strDateEnd = Format(iLastDay & "." & Month(Now) - 1 - i_PrevMonth & "." & Year(Now), "DD.MM.YYYY")
'словарь дат
Set DicDate = FnDicFilterDate(strDateStart & " - " & strDateEnd)
Debug.Print strDateStart, strDateEnd
End Sub
Function Fn_strDate_12_Month(ByVal i_PrevMonth As Integer) As String
'формируем строку для интервала дат в 12 месяцев
Dim iLastDay As Integer
'iLastDay = Day(DateSerial(2010, 5, 1) - 1)
iLastDay = Day(DateSerial(Year(Now), Month(Now) - i_PrevMonth, 1) - 0)
strDateStart = Format(1 & "." & Month(Now) - i_PrevMonth & "." & Year(Now) - 1, "DD.MM.YYYY")
strDateEnd = Format(iLastDay & "." & Month(Now) - 1 - i_PrevMonth & "." & Year(Now), "DD.MM.YYYY")
Fn_strDate_12_Month = strDateStart & " - " & strDateEnd
End Function
'=======================================================================
'===============================================================
'##### Словарь дат для сводной
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
