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

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

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()

Olá Thiago Trindade,

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

Abraço

Olá,

Precisei esse recurso e deu certo!
Muito obrigado por compartilhar.