MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    [Resolvido]Dateadd (com dias úteis e feriados)

    avatar
    thiago_e
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 10
    Registrado : 13/07/2016

    [Resolvido]Dateadd (com dias úteis e feriados) Empty [Resolvido]Dateadd (com dias úteis e feriados)

    Mensagem  thiago_e em 29/7/2020, 03:48

    Olá amigos

    Tenho uma tbl_Controle e uma tbl_Feriados

    Na tbl_controle tenho a DataEntrada, QntDias e PrazoReembolso, que preciso que o prazo seja definido de acordo com os dias inseridos em QntDias (sem contar fds e feriados)

    Procurei no repositório e encontrei uma solução do JPaulo mas que retorna o número de dias úteis entre duas datas que também utilizarei mas em outro form, mas agora preciso do inverso.

    Desde já muito obrigado
    avatar
    thiago_e
    Novato
    Novato

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 10
    Registrado : 13/07/2016

    [Resolvido]Dateadd (com dias úteis e feriados) Empty Re: [Resolvido]Dateadd (com dias úteis e feriados)

    Mensagem  thiago_e em 5/8/2020, 13:24

    Após muita pesquisa na internet achei a solução abaixo

    Criar uma tabela "Feriado" com um campo "DataFeriado" e preencha com a data dos feriados
    colar a função abaixo em um novo módulo

    Compilar e salvar

    Usar a expressão em uma consulta em branco para o resultado:
    =DateAddWorkdays(30, [Date1])

    Em VBA: No campo que irá receber a data inicial inserir a função no evento "após atualizar" e determinar qual campo irá receber o resultado
    [campo da data final] = DateAddWorkdays([número de dias ou campo onde será incluso], [campo que irá receber a data inicial])


    Código:
    Option Explicit

    ' Common constants.

        ' Date.
        Public Const DaysPerWeek        As Long = 7
        Public Const MaxDateValue       As Date = #12/31/9999#
        Public Const MinDateValue       As Date = #1/1/100#
        ' Workdays per week.
        Public Const WorkDaysPerWeek    As Long = 5
        ' Average count of holidays per week maximum.
        Public Const HolidaysPerWeek    As Long = 1

    ' Adds Number of full workdays to Date1 and returns the found date.
    ' Number can be positive, zero, or negative.
    ' Optionally, if WorkOnHolidays is True, holidays are counted as workdays.
    '
    ' For excessive parameters that would return dates outside the range
    ' of Date, either 100-01-01 or 9999-12-31 is returned.
    '
    ' Will add 500 workdays in about 0.01 second.
    '
    ' Requires table Holiday with list of holidays.
    '
    ' 2015-12-19. Gustav Brock. Cactus Data ApS, CPH.
    '
    Public Function DateAddWorkdays( _
        ByVal Number As Long, _
        ByVal Date1 As Date, _
        Optional ByVal WorkOnHolidays As Boolean) _
        As Date

        Const Interval      As String = "d"

        Dim Holidays()      As Date

        Dim Days            As Long
        Dim DayDiff         As Long
        Dim MaxDayDiff      As Long
        Dim Sign            As Long
        Dim Date2           As Date
        Dim NextDate        As Date
        Dim DateLimit       As Date
        Dim HolidayId       As Long

        Sign = Sgn(Number)
        NextDate = Date1

        If Sign <> 0 Then
            If WorkOnHolidays = True Then
                ' Holidays are workdays.
            Else
                ' Retrieve array with holidays between Date1 and Date1 + MaxDayDiff.
                ' Calculate the maximum calendar days per workweek.
                MaxDayDiff = Number * DaysPerWeek / (WorkDaysPerWeek - HolidaysPerWeek)
                ' Add one week to cover cases where a week contains multiple holidays.
                MaxDayDiff = MaxDayDiff + Sgn(MaxDayDiff) * DaysPerWeek
                If Sign > 0 Then
                    If DateDiff(Interval, Date1, MaxDateValue) < MaxDayDiff Then
                        MaxDayDiff = DateDiff(Interval, Date1, MaxDateValue)
                    End If
                Else
                    If DateDiff(Interval, Date1, MinDateValue) > MaxDayDiff Then
                        MaxDayDiff = DateDiff(Interval, Date1, MinDateValue)
                    End If
                End If
                Date2 = DateAdd(Interval, MaxDayDiff, Date1)
                ' Retrive array with holidays.
                Holidays = GetHolidays(Date1, Date2)
            End If
            Do Until Days = Number
                If Sign = 1 Then
                    DateLimit = MaxDateValue
                Else
                    DateLimit = MinDateValue
                End If
                If DateDiff(Interval, DateAdd(Interval, DayDiff, Date1), DateLimit) = 0 Then
                    ' Limit of date range has been reached.
                    Exit Do
                End If

                DayDiff = DayDiff + Sign
                NextDate = DateAdd(Interval, DayDiff, Date1)
                Select Case Weekday(NextDate)
                    Case vbSaturday, vbSunday
                        ' Skip weekend.
                    Case Else
                        ' Check for holidays to skip.
                        ' Ignore error when using LBound and UBound on an unassigned array.
                        On Error Resume Next
                        For HolidayId = LBound(Holidays) To UBound(Holidays)
                            If Err.Number > 0 Then
                                ' No holidays between Date1 and Date2.
                            ElseIf DateDiff(Interval, NextDate, Holidays(HolidayId)) = 0 Then
                                ' This NextDate hits a holiday.
                                ' Subtract one day before adding one after the loop.
                                Days = Days - Sign
                                Exit For
                            End If
                        Next
                        On Error GoTo 0
                        Days = Days + Sign
                End Select
            Loop
        End If

        DateAddWorkdays = NextDate

    End Function

    ' Returns the holidays between Date1 and Date2.
    ' The holidays are returned as a recordset with the
    ' dates ordered ascending, optionally descending.
    '
    ' Requires table Holiday with list of holidays.
    '
    ' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
    '
    Public Function DatesHoliday( _
        ByVal Date1 As Date, _
        ByVal Date2 As Date, _
        Optional ByVal ReverseOrder As Boolean) _
        As DAO.Recordset

        ' The table that holds the holidays.
        Const Table         As String = "Feriado"
        ' The field of the table that holds the dates of the holidays.
        Const Field         As String = "DataFeriado"

        Dim rs              As DAO.Recordset

        Dim SQL             As String
        Dim SqlDate1        As String
        Dim SqlDate2        As String
        Dim Order           As String

        SqlDate1 = Format(Date1, "\#yyyy\/mm\/dd\#")
        SqlDate2 = Format(Date2, "\#yyyy\/mm\/dd\#")
        ReverseOrder = ReverseOrder Xor (DateDiff("d", Date1, Date2) < 0)
        Order = IIf(ReverseOrder, "Desc", "Asc")

        SQL = "Select " & Field & " From " & Table & " " & _
            "Where " & Field & " Between " & SqlDate1 & " And " & SqlDate2 & " " & _
            "Order By 1 " & Order

        Set rs = CurrentDb.OpenRecordset(SQL, dbOpenSnapshot)

        Set DatesHoliday = rs

    End Function

    ' Returns the holidays between Date1 and Date2.
    ' The holidays are returned as an array with the
    ' dates ordered ascending, optionally descending.
    '
    ' The array is declared static to speed up
    ' repeated calls with identical date parameters.
    '
    ' Requires table Holiday with list of holidays.
    '
    ' 2015-12-18. Gustav Brock, Cactus Data ApS, CPH.
    '
    Public Function GetHolidays( _
        ByVal Date1 As Date, _
        ByVal Date2 As Date, _
        Optional ByVal OrderDesc As Boolean) _
        As Date()

        ' Constants for the arrays.
        Const DimRecordCount    As Long = 2
        Const DimFieldOne       As Long = 0

        Static Date1Last        As Date
        Static Date2Last        As Date
        Static OrderLast        As Boolean
        Static DayRows          As Variant
        Static Days             As Long

        Dim rs                  As DAO.Recordset

        ' Cannot be declared Static.
        Dim Holidays()          As Date

        If DateDiff("d", Date1, Date1Last) <> 0 Or _
            DateDiff("d", Date2, Date2Last) <> 0 Or _
            OrderDesc <> OrderLast Then

            ' Retrieve new range of holidays.
            Set rs = DatesHoliday(Date1, Date2, OrderDesc)

            ' Save the current set of date parameters.
            Date1Last = Date1
            Date2Last = Date2
            OrderLast = OrderDesc

            Days = rs.RecordCount
                If Days > 0 Then
                    ' As repeated calls may happen, do a movefirst.
                    rs.MoveFirst
                    DayRows = rs.GetRows(Days)
                    ' rs is now positioned at the last record.
                End If
            rs.Close
        End If

        If Days = 0 Then
            ' Leave Holidays() as an unassigned array.
            Erase Holidays
        Else
            ' Fill array to return.
            ReDim Holidays(Days - 1)
            For Days = LBound(DayRows, DimRecordCount) To UBound(DayRows, DimRecordCount)
                Holidays(Days) = DayRows(DimFieldOne, Days)
            Next
        End If

        Set rs = Nothing

        GetHolidays = Holidays()


    Última edição por thiago_e em 6/8/2020, 18:32, editado 2 vez(es)
    ahteixeira
    ahteixeira
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6956
    Registrado : 15/03/2013

    [Resolvido]Dateadd (com dias úteis e feriados) Empty Re: [Resolvido]Dateadd (com dias úteis e feriados)

    Mensagem  ahteixeira em 5/8/2020, 16:08

    Olá Thiago Trindade,

    Que bom que resolveu, obrigado pela partilha o fórum agradece.

    Abraço

      Data/hora atual: 28/11/2020, 02:28