日期差异，排除特定时间和日期

Question

我正在寻找一种方法来确定两个日期之间的差异。 正常的SQL DATEDIFF语句不会削减它，因为我需要排除非工作时间和日期即周末和16:00 - 7:00之间的任何时间。

与Excel中的NETWORKDAYS函数类似。

我正在编写一个excel电子表格。使用VBA连接到SQL服务器来提取数据。

Answer 1

这是一个代码示例，我从网上下来并修改它以使用存储在访问表中的日期表。我敢肯定，你可以在一个范围在工作表等再次将其更改为点，但基本思想工作的一种享受

Option Compare Database 
Option Explicit 

Public Function dhCountWorkdaysA(ByVal dtmStart As Date, ByVal dtmEnd As Date, _ 
Optional adtmDates As Variant = Empty) _ 
As Integer 

    ' Count the business days (not counting weekends/holidays) in 
    ' a given date range. 

    ' Modified from code in 
    ' "Visual Basic Language Developer's Handbook" 
    ' by Ken Getz and Mike Gilbert 
    ' Copyright 2000; Sybex, Inc. All rights reserved. 

    ' Requires: 
    ' SkipHolidays 
    ' CountHolidays 
    ' IsWeekend 

    ' In: 
    ' dtmStart: 
    '  Date specifying the start of the range (inclusive) 
    ' dtmEnd: 
    '  Date specifying the end of the range (inclusive) 
    '  (dates will be swapped if out of order) 
    ' adtmDates (Optional): 
    '  Array containing holiday dates. Can also be a single 
    '  date value. 
    ' Out: 
    ' Return Value: 
    '  Number of working days (not counting weekends and optionally, holidays) 
    '  in the specified range. 
    ' Example: 
    ' Debug.Print dhCountWorkdaysA(#7/2/2000#, #7/5/2000#, _ 
    ' Array(#1/1/2000#, #7/4/2000#)) 
    ' 
    ' returns 2, because 7/2/2000 is Sunday, 7/4/2000 is a holiday, 
    ' leaving 7/3 and 7/5 as workdays. 

    Dim intDays As Integer 
    Dim dtmTemp As Date 
    Dim intSubtract As Integer 

    ' Swap the dates if necessary.> 
    If dtmEnd < dtmStart Then 
     dtmTemp = dtmStart 
     dtmStart = dtmEnd 
     dtmEnd = dtmTemp 
    End If 

    ' Get the start and end dates to be weekdays. 
    dtmStart = SkipHolidaysA(adtmDates, dtmStart, 1) 
    dtmEnd = SkipHolidaysA(adtmDates, dtmEnd, -1) 
    If dtmStart > dtmEnd Then 
     ' Sorry, no Workdays to be had. Just return 0. 
     dhCountWorkdaysA = 0 
    Else 
     intDays = dtmEnd - dtmStart + 1 

     ' Subtract off weekend days. Do this by figuring out how 
     ' many calendar weeks there are between the dates, and 
     ' multiplying the difference by two (because there are two 
     ' weekend days for each week). That is, if the difference 
     ' is 0, the two days are in the same week. If the 
     ' difference is 1, then we have two weekend days. 
     intSubtract = (DateDiff("ww", dtmStart, dtmEnd) * 2) 

     ' The answer to our quest is all the weekdays, minus any 
     ' holidays found in the table. 
     intSubtract = intSubtract + _ 
     CountHolidaysA(adtmDates, dtmStart, dtmEnd) 

     dhCountWorkdaysA = intDays - intSubtract 
    End If 
End Function 
Private Function CountHolidaysA(_ 
adtmDates As Variant, _ 
dtmStart As Date, dtmEnd As Date) As Long 

    ' Count holidays between two end dates. 
    ' 
    ' Modified from code in 
    ' "Visual Basic Language Developer's Handbook" 
    ' by Ken Getz and Mike Gilbert 
    ' Copyright 2000; Sybex, Inc. All rights reserved. 

    ' Required by: 
    ' dhCountWorkdays 

    ' Requires: 
    ' IsWeekend 


    Dim lngItem As Long 
    Dim lngCount As Long 
    Dim blnFound As Long 
    Dim dtmTemp As Date 

    On Error GoTo HandleErr 
    lngCount = 0 
    Select Case VarType(adtmDates) 
     Case vbArray + vbDate, vbArray + vbVariant 
      ' You got an array of variants, or of dates. 
      ' Loop through, looking for non-weekend values 
      ' between the two endpoints. 
      For lngItem = LBound(adtmDates) To UBound(adtmDates) 
       dtmTemp = adtmDates(lngItem) 
       If dtmTemp >= dtmStart And dtmTemp <= dtmEnd Then 
        If Not IsWeekend(dtmTemp) Then 
         lngCount = lngCount + 1 
        End If 
       End If 
      Next lngItem 
     Case vbDate 
      ' You got one date. So see if it's a non-weekend 
      ' date between the two endpoints. 
      If adtmDates >= dtmStart And adtmDates <= dtmEnd Then 
       If Not IsWeekend(adtmDates) Then 
        lngCount = 1 
       End If 
      End If 
    End Select 

ExitHere: 
    CountHolidaysA = lngCount 
    Exit Function 

HandleErr: 
    ' No matter what the error, just 
    ' return without complaining. 
    ' The worst that could happen is that the code 
    ' include a holiday as a real day, even if 
    ' it's in the table. 
    Resume ExitHere 
End Function 


Public Function dhAddWorkDaysA(lngDays As Long, Optional dtmDate As Date = 0) 
'Optional adtmDates As Variant) As Date 
    ' Add the specified number of work days to the 
    ' specified date. 

    ' Modified from code in 
    ' "Visual Basic Language Developer's Handbook" 
    ' by Ken Getz and Mike Gilbert 
    ' Copyright 2000; Sybex, Inc. All rights reserved. 

    ' In: 
    ' lngDays: 
    '  Number of work days to add to the start date. 
    ' dtmDate: 
    '  date on which to start looking. 
    '  Use the current date, if none was specified. 
    ' adtmDates (Optional): 
    '  Array containing holiday dates. Can also be a single 
    '  date value, if that's what you want. 
    ' Out: 
    ' Return Value: 
    '  The date of the working day lngDays from the start, taking 
    '  into account weekends and holidays. 
    ' Example: 
    ' dhAddWorkDaysA(10, #2/9/2000#, Array(#2/16/2000#, #2/17/2000#)) 
    ' returns #2/25/2000#, which is the date 10 work days 
    ' after 2/9/2000, if you treat 2/16 and 2/17 as holidays 
    ' (just made-up holidays, for example purposes only). 

    ' Did the caller pass in a date? If not, use 
    ' the current date. 
    Dim lngCount As Long 
    Dim dtmTemp As Date 
    Dim adtmDates() As Variant 

    'loadup the adtmDates with all the records from the table tblNon_working_days 
    Dim db As DAO.Database 
    Dim rst As DAO.Recordset 
    Dim i As Long 


    Set rst = DBEngine(0)(0).OpenRecordset("tblNon_working_days", dbOpenSnapshot) 
    With rst 
     If .RecordCount > 0 Then 
      i = 1 
      .MoveFirst 
      Do Until .EOF 
       ReDim Preserve adtmDates(i) 
       adtmDates(i) = !Date 
       .MoveNext 
       i = i + 1 
      Loop 
     End If 
    End With 

    rst.Close 
    db.Close 
    Set rst = Nothing 
    Set db = Nothing 

    If dtmDate = 0 Then 
     dtmDate = Date 
    End If 

    dtmTemp = dtmDate 
    For lngCount = 1 To lngDays 
     dtmTemp = dhNextWorkdayA(dtmTemp, adtmDates) 
    Next lngCount 
    dhAddWorkDaysA = dtmTemp 
End Function 
Public Function dhNextWorkdayA(_ 
Optional dtmDate As Date = 0, _ 
Optional adtmDates As Variant = Empty) As Date 

    ' Return the next working day after the specified date. 

    ' Modified from code in 
    ' "Visual Basic Language Developer's Handbook" 
    ' by Ken Getz and Mike Gilbert 
    ' Copyright 2000; Sybex, Inc. All rights reserved. 

    ' Requires: 
    ' SkipHolidays 
    ' IsWeekend 

    ' In: 
    ' dtmDate: 
    '  date on which to start looking. 
    '  Use the current date, if none was specified. 
    ' adtmDates (Optional): 
    '  Array containing holiday dates. Can also be a single 
    '  date value. 
    ' Out: 
    ' Return Value: 
    '  The date of the next working day, taking 
    '  into account weekends and holidays. 
    ' Example: 
    ' ' Find the next working date after 5/30/97 
    ' dtmDate = dhNextWorkdayA(#5/23/1997#, #5/26/97#) 
    ' ' dtmDate should be 5/27/97, because 5/26/97 is Memorial day. 

    ' Did the caller pass in a date? If not, use 
    ' the current date. 
    If dtmDate = 0 Then 
     dtmDate = Date 
    End If 

    dhNextWorkdayA = SkipHolidaysA(adtmDates, dtmDate + 1, 1) 
End Function 
Private Function SkipHolidaysA(_ 
adtmDates As Variant, _ 
dtmTemp As Date, intIncrement As Integer) As Date 
    ' Skip weekend days, and holidays in the array referred to by adtmDates. 
    ' Return dtmTemp + as many days as it takes to get to a day that's not 
    ' a holiday or weekend. 

    ' Modified from code in 
    ' "Visual Basic Language Developer's Handbook" 
    ' by Ken Getz and Mike Gilbert 
    ' Copyright 2000; Sybex, Inc. All rights reserved. 

    ' Required by: 
    ' dhFirstWorkdayInMonthA 
    ' dbLastWorkdayInMonthA 
    ' dhNextWorkdayA 
    ' dhPreviousWorkdayA 
    ' dhCountWorkdaysA 

    ' Requires: 
    ' IsWeekend 

    Dim strCriteria As String 
    Dim strFieldName As String 
    Dim lngItem As Long 
    Dim blnFound As Boolean 

    On Error GoTo HandleErrors 

    ' Move up to the first Monday/last Friday, if the first/last 
    ' of the month was a weekend date. Then skip holidays. 
    ' Repeat this entire process until you get to a weekday. 
    ' Unless adtmDates an item for every day in the year (!) 
    ' this should finally converge on a weekday. 

    Do 
     Do While IsWeekend(dtmTemp) 
      dtmTemp = dtmTemp + intIncrement 
     Loop 
     Select Case VarType(adtmDates) 
      Case vbArray + vbDate, vbArray + vbVariant 
       Do 
        blnFound = FindItemInArray(dtmTemp, adtmDates) 
        If blnFound Then 
         dtmTemp = dtmTemp + intIncrement 
        End If 
       Loop Until Not blnFound 
      Case vbDate 
       If dtmTemp = adtmDates Then 
        dtmTemp = dtmTemp + intIncrement 
       End If 
     End Select 
    Loop Until Not IsWeekend(dtmTemp) 

ExitHere: 
    SkipHolidaysA = dtmTemp 
    Exit Function 

HandleErrors: 
    ' No matter what the error, just 
    ' return without complaining. 
    ' The worst that could happen is that we 
    ' include a holiday as a real day, even if 
    ' it's in the array. 
    Resume ExitHere 

End Function 
Private Function IsWeekend(dtmTemp As Variant) As Boolean 
    ' If your weekends aren't Saturday (day 7) and Sunday (day 1), 
    ' change this routine to return True for whatever days 
    ' you DO treat as weekend days. 

    ' Modified from code in "Visual Basic Language Developer's Handbook" 
    ' by Ken Getz and Mike Gilbert 
    ' Copyright 2000; Sybex, Inc. All rights reserved. 

    ' Required by: 
    ' SkipHolidays 
    ' dhFirstWorkdayInMonth 
    ' dbLastWorkdayInMonth 
    ' dhNextWorkday 
    ' dhPreviousWorkday 
    ' dhCountWorkdays 

    If VarType(dtmTemp) = vbDate Then 
     Select Case WeekDay(dtmTemp) 
      Case vbSaturday, vbSunday 
       IsWeekend = True 
      Case Else 
       IsWeekend = False 
     End Select 
    End If 
End Function 

Private Function FindItemInArray(varItemToFind As Variant, _ 
avarItemsToSearch As Variant) As Boolean 
    Dim lngItem As Long 

    On Error GoTo HandleErrors 

    For lngItem = LBound(avarItemsToSearch) To UBound(avarItemsToSearch) 
     If avarItemsToSearch(lngItem) = varItemToFind Then 
      FindItemInArray = True 
      GoTo ExitHere 
     End If 
    Next lngItem 

ExitHere: 
    Exit Function 

HandleErrors: 
    ' Do nothing at all. 
    ' Return False. 
    Resume ExitHere 
End Function