VBA - Добавить дни с выходными, за исключением выходных текущей недели

Question

Я хочу создать код VBA, в котором вы берете один рабочий день, d добавляете к нему n количество дней, и он возвращает дату n количество дней спустя, y, исключая выходные дни в течениенеделю d.Примечание: если y выпадает на выходные, он должен вернуться в предыдущий рабочий день.

d + n - (weekend of d week) = y

Например, завтра 09/27, если я посчитаю 14 дней после, включая выходные, за исключением выходных этой недели.Было бы, что-то вроде этого:

09/27 + 14 days - (weekend of 09/27 week) = 10/12


Tomorrow: 09/27
+1: 09/28
Not Counted: 09/29 (Saturday of this week)
Not Counted: 09/30 (Sunday of this week)
+2: 10/01 (Here pass for the next workday, and from here can count the weekends after)
+3: 10/02
+4: 10/03
+5: 10/04
+6: 10/05
+7: 10/06 (this day is Saturday, can be counted)
+8: 10/07 (this day is Sunday, can be counted)
+9: 10/08
+10: 10/09
+11: 10/10
+12: 10/11
+13: 10/12
+14 10/13 <- adding the days fall on this date. But, this day is a Saturday, so, comes back to previous workday, which is 10/12

Как я могу построить что-то вроде этого?

Answer 1

Дата исполнения: пропуск первых выходных, минус последние выходные

Option Explicit
'With Project ==================================================================
'  .Title: DueDateFWSLWL - Due Date: First Weekend Skip, Last Weekend Less
'  .Author: YMG
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  With .Contents
'    Sub DueDateTester
'*** Function DueDateFWSLWL ***
'    Function WeekDayShifter
'  End With
'===============================================================================
'
'-------------------------------------------------------------------------------
Sub DueDateTester()
'
'Description
'  Practical use of the DueDateFWSLWL Function.
'Parameters
'  None
'Returns
'  Various outputs of dates as the result of the DueDateFWSLWL Function.
'
'-- Customize BEGIN --------------------
  Const Days As Long = 14
'-- Customize END ----------------------
'
  Debug.Print DueDateFWSLWL(Days)
  MsgBox DueDateFWSLWL(Days), vbInformation, "Due Date"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'or
  Dim loF1 As Long
  Dim str1 As String
  str1 = "Due Date from 1 to 100"
  For loF1 = 1 To 100 Step 2
    str1 = str1 & vbCrLf & loF1 & Chr(9) & DueDateFWSLWL(loF1)
  Next
    Debug.Print str1
    MsgBox str1, vbInformation, "Due Date"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'or
'In Excel used as any other function e.g. type into cell A1 the number of days,
'and into another cell =DueDateFWSLWL(A1)
'etc.
'
End Sub
'
'-------------------------------------------------------------------------------
Function DueDateFWSLWL(Days As Long) As Date
'
'Description
'  Calculates a 'due' date after a specified number of days counting from today,
'  not counting the first weekend and shifting back to friday if it results on a
'  weekend.
'Parameters¸
'  cDays - The number of days.
'Returns
'  The 'due' date.
'Precendents
'  Function WeekDayShifter
'
  Dim Today As Date
  Dim iWD As Integer
  Dim iFirstWeekend As Integer
  Dim loDays As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  'Date Function: Returns a Variant (Date) containing the current system date.
  Today = Date
  iWD = WeekDayShifter(Weekday(Today))
  iFirstWeekend = 7 - iWD 'Results from 0-6
  If iFirstWeekend < Days + 2 Then
    Select Case iFirstWeekend
      Case 0 'It's a sunday.
        loDays = Days '+ 0 '0 for monday.
      Case 1 'It's a saturday.
        loDays = Days + 1 '1 for sunday.
      Case Else 'It's a workday.
        loDays = Days + 2 '2 for first weekend (Saturday & Sunday).
    End Select
   Else
'
'Time has run out. Sorry.
'
'This code might be wrong BEGIN ------------------------------------------------
'But its only here for some ridiculous inputs like 1 or 2 days, so I don't care.
    Select Case WeekDayShifter(Weekday(Today + Days))
      Case 0 'It's a sunday.
        loDays = Days - 2 '2 for sunday.
      Case 1 'It's a saturday.
        loDays = Days - 1 '1 for saturday.
      Case Else 'It's a workday
        loDays = Days '-0 '0 for workday.
    End Select
'This code might be wrong END --------------------------------------------------
'
  End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  DueDateFWSLWL = Today + loDays
  Select Case WeekDayShifter(Weekday(DueDateFWSLWL))
    Case 7 'Sunday
      DueDateFWSLWL = DueDateFWSLWL - 2
    Case 6 'Saturday
      DueDateFWSLWL = DueDateFWSLWL - 1
  End Select
'
End Function
'
'-------------------------------------------------------------------------------
Function WeekDayShifter(Weekday As Integer) As Integer
'
'Description
'  Shifts the results of the Weekday Function so that monday is the first day of
'  the week and sunday the last (7th).
'Parameters
'  Weekday - Default weekday from the Visual Basic Weekday Function.
'Returns
'  A 'shifted' weekday integer.
'Dependents
'  Function DueDateFWSLWL
'
  If Not IsNumeric(Weekday) Or Weekday < 1 Or Weekday > 7 Then Exit Function
  If Weekday <> 1 Then
    WeekDayShifter = Weekday - 1 'From monday to saturday
   Else
    WeekDayShifter = 7 'Sunday
  End If
'
''''''''''''''''''''''''''''''''''''''''
' Weekday Function: ' WeekDayShifter:  '
'  1 - Sunday *     '  1 - Monday      '
'  2 - Monday       '  2 - Tuesday     '
'  3 - Tuesday      '  3 - Wednesday   '
'  4 - Wednesday    '  4 - Thursday    '
'  5 - Thursday     '  5 - Friday      '
'  6 - Friday       '  6 - Saturday *  '
'  7 - Saturday *   '  7 - Sunday *    '
''''''''''''''''''''''''''''''''''''''''
'
End Function
'-------------------------------------------------------------------------------
'
'With Idea Source --------------------------------------------------------------
'  .Title: VBA - Add days with weekends, less the weekend of actual week
'  .TitleURL: /11484899/vba-dobavit-dni-s-vyhodnymi-za-isklycheniem-vyhodnyh-tekuschei-nedeli
'  .Author: L.Th
'  .AuthorURL: https://stackoverflow.com/users/10009861/l-th
'End With ----------------------------------------------------------------------
'
'End With ======================================================================

Answer 2

Вы также можете сделать это с помощью функции рабочего листа.Эквивалент VBA:

Function dueDate(startDt As Date, numDays As Long) As Date

With Application.WorksheetFunction
    dueDate = .WorkDay(.WorkDay(startDt, 5) + numDays - 5 + 1, -1)
End With

End Function

Функция рабочего листа одинакова:

=WORKDAY(WORKDAY(StartDt,5)+numDays-5+1,-1)

Answer 3

Я получил это здесь!Я выложу код, если кто-то поможет.

Sub Example()

Dim Day, FinalDay As Date, ActualWeekend As String, DaysToAdd As Integer

DaysToAdd = 14
Day = CDate(Left(Now() + 1, 10)) 'here i add +1 to see if the final day ends on 10/13, but you can put any date as you wish
ActualWeekend = True

For i = 1 To DaysToAdd
    If (Weekday(CDate(Day) + 1) = 7 Or Weekday(CDate(Day) + 1) = 1) And ActualWeekend = True Then
        Day = CDate(WorksheetFunction.WorkDay(Day, 1))
        ActualWeekend = False
    Else
        Day = Day + 1
    End If
Next i

FinalDay = Day

If Weekday(CDate(FinalDay)) = 7 Or Weekday(CDate(FinalDay)) = 1 Then
    FinalDay = CDate(WorksheetFunction.WorkDay(FinalDay, -1))
End If

MsgBox FinalDay

End Sub