MyTetra Share
Делитесь знаниями!
Последний день месяца
18.03.2019
14:08
Текстовые метки: Последний_день_месяца
Раздел: !Закладки - VBA - Операции с датами-временем

'=======================================================================

'// 'формируем строку для интервала дат в 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


 
MyTetra Share v.0.52
Яндекс индекс цитирования