Autor Tema: Cálculo de dia laborable flexivo  (Leído 730 veces)

Desconectado xavi

  • Administrador
  • Habitual
  • *****
  • Mensajes: 214
Cálculo de dia laborable flexivo
« en: Mayo 27, 2023, 05:55:40 pm »
Palabras clave: fecha, laborable, dia.lab.intl
Autor: xavi

Necesidad
Obtener que día será una fecha dada una fecha inicial, un número de laborales, un tipo de semana laboral y la utilización de una tabla de festivos.

Es una emulación (con ligeros cambios) de la función DIA.LAB.INTL de Excel

Código: [Seleccionar]
Function DiaLabIntl(dtmFechaInicial As Date, intDiasProceso As Integer, Optional strTipoSemanaLaboral As String = "0000011", Optional blnAplicaFestivos As Boolean = True) As Date
    ' Función análoga a la de Excel utilizando el tipo de semana laboral como cadena y un boolean para aplicar laborables y festivos
    ' En caso de aplicar festivos será necesario indicar el nombre de la tabla y el campo de la tabla que contiene la fecha
   
    ' La cadena de strTipoSemanaLaboral se establece con 7 ceros y unos. El cero indica laborable y el uno festivo.
    ' Así, "0000011" indica el fin de semana de sábado-domingo. Esa técnica nos permite gestionar (casi) cualquier combinación
   
   
    Const cTablaFestivos As String = "tblDatFestivos"
    Const cCampoFecha As String = "FechaFestiva"
   
    Dim dtmLaFecha  As Date
    Dim intdias As Integer
   
    ' Establecemos la fecha inicial
    dtmLaFecha = dtmFechaInicial
   
    ' Bucle sin condiciones
    Do
        ' Evaluamos si el día de la semana se ha estipulado como festivo.
        If Mid(strTipoSemanaLaboral, Weekday(dtmLaFecha, vbMonday), 1) = "1" Then
            ' Es un NO-laborable: no hacemos nada
        Else
            ' En este punto "parece" un laborable pero miramos si es festivo (si procede)
            If blnAplicaFestivos And DCount("*", cTablaFestivos, cCampoFecha & "= " & CLng(dtmLaFecha)) > 0 Then
                ' es un festivo: nada
            Else
                ' Ni es fin de semana, ni es festivo (sea porque no aplica, sea porque no lo es)
                intdias = intdias + 1
            End If
        End If
       
        ' Comprobamos si hemos alcanzado el limite de días
        If intdias >= intDiasProceso Then
            DiaLabIntl = dtmLaFecha
            Exit Function
        End If
        ' Aumentamos un día
        dtmLaFecha = DateAdd("d", 1, dtmLaFecha)
        ' Comprobación de seguridad
        If dtmLaFecha > DateAdd("d", intDiasProceso + 1000, dtmFechaInicial) Then
            MsgBox "Creo que nos hemos pasado de largo", vbExclamation
            DiaLabIntl = "01/01/1900"
            Exit Function
        End If
    Loop

End Function

« Última modificación: Junio 02, 2023, 01:40:15 pm por xavi »