Loop through a start and end date, paste only weekdays in VBA

[janki6566]

Hello,

I have macro in which I have a start date and an end date. For every loop, I need to paste the start date to the end date but not include the weekends. In section 3 of my code, I have it to where it will start with the start date and loop through until it gets to the number of weekdays but it still paste days sequentially instead of excluding weekends. So for example, my start date could be 10/12/2020 and my end date could be 10/22/2020, it know that there is only 9 weekdays but it still pastes the weekend dates and stops after 9 instead of excluding the weekend dates when pasting in column BA. Additionally, the dates paste down in three ways, increases 1 row at a time (ie 10/12, 10/13, 10/14), increases 1 day at time but duplicates ( ie 10/12, 10/12, 10/13, 10/13) or it increases 1 row at a time and then duplicates one last time (ie 10/12, 10/13, 10/14, 10, 14)

any help is appreciated.

Sub A_process_data()

Application.ScreenUpdating = False

'declaration of variables
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lr1 As Long, lr2 As Long, xLoop As Long
Dim cRow As Integer, rLoop As Integer, idays As Integer
Dim sh2 As String, sh5 As String, sh6 As String, sh7 As String, sh8 As String, sh11 As String, sh12 As String, sh13 As String, Sh14 As String, Sh15 As String, sh16 As String
Dim sh1 As Long
Dim sh3 As Integer, sh4 As Integer
Dim sh9 As Date, sh10 As Date, dstart As Date, dend As Date
Dim shT As String, shR As String


'set worksheet variables
Set ws1 = Sheet1
Set ws2 = Sheet2



'get last row of delivery template
lr1 = ws1.Range("A1048576").End(xlUp).Row

'set last row of manage course offering after clearing
ws2.Range("6:1048576").ClearContents
lr2 = 6



'loop through all rows of delivery template
For xLoop = 3 To lr1

    'set delivery template values into variable
    sh1 = ws1.Range("A" & xLoop).Value 'locator
    sh2 = ws1.Range("B" & xLoop).Value 'course name
    sh3 = ws1.Range("I" & xLoop).Value 'min enr
    sh4 = ws1.Range("J" & xLoop).Value 'max enr
    sh5 = ws1.Range("L" & xLoop).Value 'instructor
    sh6 = ws1.Range("M" & xLoop).Value 'secondary instructor
    sh7 = ws1.Range("N" & xLoop).Value 'T3 instructor
    sh8 = ws1.Range("O" & xLoop).Value 'Primary location
    sh9 = ws1.Range("U" & xLoop).Value 'start date
    sh10 = ws1.Range("W" & xLoop).Value 'end date
    sh11 = ws1.Range("K" & xLoop).Value 'language
    sh12 = ws1.Range("G" & xLoop).Value 'Pricing
    sh13 = ws1.Range("H" & xLoop).Value 'Track Grades
    Sh14 = ws1.Range("V" & xLoop).Value 'start time
    Sh15 = ws1.Range("X" & xLoop).Value 'end time
    sh16 = ws1.Range("E" & xLoop).Value 'LR Start time
    Sh17 = ws1.Range("P" & xLoop).Value 'Room Location
    sh18 = ws1.Range("Q" & xLoop).Value 'Private Onsite Location Address
    sh19 = ws1.Range("R" & xLoop).Value 'Private Onsite Location Room
    sh20 = ws1.Range("S" & xLoop).Value 'Private Onsite Location Time Zone
    sh22 = ws1.Range("C" & xLoop).Value 'LIP or Webinar
    sh23 = ws1.Range("T" & xLoop).Value 'TimeZone for Webinar
    Sh24 = ws1.Range("F" & xLoop).Value 'Pricing Enable
    sh25 = ws1.Range("D" & xLoop).Value 'Teach Type
  
    'custom variable for getting title
    shR = WorksheetFunction.Substitute(sh2, "_", "~", Len(sh2) - Len(Replace(sh2, "_", "")) - 1)
    shT = Replace(Left(shR, InStr(1, shR, "~") - 1), "_", " ")
  
  
'LIP columns
If sh22 = "LIP" Then
  
    'number of instances
    If (sh25 = "Regular" Or sh25 = "Onsite") Then
        cRow = (Application.WorksheetFunction.NetworkDays_Intl(sh9, sh10, 1))
    ElseIf sh25 = "CoTeach" Then
            cRow = (Application.WorksheetFunction.NetworkDays_Intl(sh9, sh10, 1)) * 2
    ElseIf sh25 = "T3" Then
        cRow = (Application.WorksheetFunction.NetworkDays_Intl(sh9, sh10, 1)) + 1
    End If

  
    'loop to place values
    For rLoop = 0 To cRow - 1
  
        '1. days display vertically LIP
        ws2.Range("AO" & rLoop + lr2).Value = rLoop + 1
        ws2.Range("AQ" & rLoop + lr2).Value = rLoop + 1
     
       
       
        '2. title and day
         If sh25 = "CoTeach" Then
           ws2.Range("AS" & rLoop + lr2).Value = shT & "- Day" & Application.WorksheetFunction.RoundUp((rLoop + 1) / 2, 0)
        Else
           If sh25 = "T3" And rLoop = cRow - 1 Then ' added 10/19/2001 if on the last row
              ws2.Range("AS" & rLoop + lr2).Value = shT & "- Day" & rLoop
           Else
               ws2.Range("AS" & rLoop + lr2).Value = shT & "- Day" & rLoop + 1
           End If
        End If
      
        '3. Same date, Start time to End time 1 by 1
        If (sh25 = "Regular" Or sh25 = "Onsite") Then
            ws2.Range("BA" & rLoop + lr2).Value = ((sh9) + rLoop) + (Sh14)
            ws2.Range("BB" & rLoop + lr2).Value = ((sh9) + rLoop) + (Sh15)
        ElseIf sh25 = "CoTeach" Then
            ws2.Range("BA" & rLoop + lr2).Value = ((sh9) + Application.WorksheetFunction.RoundUp((rLoop + 1) / 2, 0)) + (Sh14)
            ws2.Range("BB" & rLoop + lr2).Value = ((sh9) + Application.WorksheetFunction.RoundUp((rLoop + 1) / 2, 0)) + (Sh15)
          
        Else
            If sh25 = "T3" And rLoop = cRow - 1 Then
                ws2.Range("BA" & rLoop + lr2).Value = ((sh9) + rLoop + 1) + (Sh14)
                ws2.Range("BB" & rLoop + lr2).Value = ((sh9) + rLoop + 1) + (Sh15)
            Else
                ws2.Range("BA" & rLoop + lr2).Value = ((sh9) + rLoop) + (Sh14)
                ws2.Range("BB" & rLoop + lr2).Value = ((sh9) + rLoop) + (Sh15)
            End If
        End If
          
        
        
         '3.1 LR Start Time
         If sh16 = "Yes" Then
            ws2.Range("BA" & lr2).Value = (sh9) + ("8:30 am")
            End If
          
          
        '4. Static values
        ws2.Range("F" & rLoop + lr2).Value = 1
        ws2.Range("AR" & rLoop + lr2).Value = "Y"
        ws2.Range("BC" & rLoop + lr2).Value = "Y"
      
        '5. Exam only if Services
        If sh13 = "Yes" Then
            ws2.Range("BD" & rLoop + lr2).Value = "Y"
            ws2.Range("BE" & rLoop + lr2).Value = "Pass/Fail"
            ws2.Range("BR" & lr2 + cRow + 1).Value = "no"
            ws2.Range("BS" & lr2 + cRow + 1).Value = "Multiple Choice Exam"
            ws2.Range("BT" & lr2 + cRow + 1).Value = "Exam"
        End If
      
        '6. Repeat to all rows in column AU and AP
       If (sh25 = "Regular" Or sh25 = "Onsite") Then
            ws2.Range("AU" & rLoop + lr2).Value = get_id(sh5)
        ElseIf sh25 = "CoTeach" Then ' alternate outputting the primary and secondary instructors
                If Application.WorksheetFunction.IsEven(rLoop) Then
                    ws2.Range("AU" & rLoop + lr2).Value = get_id(sh5)
                Else
                    ws2.Range("AU" & rLoop + lr2).Value = get_id(sh6)
                End If
        ElseIf sh25 = "T3" And rLoop = cRow - 1 Then ' added 10/19/2001
                ws2.Range("AU" & rLoop + lr2).Value = get_id(sh5) 'output the T3 instructor
            Else
                ws2.Range("AU" & rLoop + lr2).Value = get_id(sh7) ' output the T3 instructor from column P
        End If
      
        '6.1 Get room location
        If (sh25 = "Regular" Or sh25 = "CoTeach") Then
            ws2.Range("AV" & rLoop + lr2).Value = Sh17
        Else
            ws2.Range("AW" & rLoop + lr2).Value = "Private Onsite"
            ws2.Range("AX" & rLoop + lr2).Value = sh18
            ws2.Range("AY" & rLoop + lr2).Value = sh19
            ws2.Range("AZ" & rLoop + lr2).Value = sh20
        End If
Next rLoop

    'Courses with an exam get an extra row
    If sh13 = "Yes" Then
        vCounter = 1
    Else
        vCounter = 0
    End If
    'Numbering of unique entries (per row)
    For rLoop = 0 To cRow + vCounter
         ws2.Range("B" & rLoop + lr2).Value = xLoop - 2
         ws2.Range("F" & rLoop + lr2).Value = 1
         ws2.Range("AO" & rLoop + lr2).Value = rLoop + 1
         ws2.Range("AQ" & rLoop + lr2).Value = rLoop + 1
    Next rLoop
  
    '7. Course Title to 1st instance of row
    ws2.Range("E" & lr2).Value = sh2
  
    '8. Offering number in 1st row only
    ws2.Range("G" & lr2).Value = sh1
    ws2.Range("D" & lr2).Value = sh1
  
    '9. Static values in first row only
    ws2.Range("I" & lr2).Value = "Y"
    ws2.Range("M" & lr2).Value = "N"
    ws2.Range("N" & lr2).Value = 0
    ws2.Range("O" & lr2).Value = "N"
  
    '10. Min Enroll Capacity on 1st row only
    ws2.Range("K" & lr2).Value = sh3
  
    '11. Max Enroll Capacity on 1st row only
    ws2.Range("L" & lr2).Value = sh4
  
    '12. Employee ID of E, first row only
    If sh5 <> "" Then ws2.Range("AG" & lr2).Value = get_id(sh5)
  
  
    '13.Language code, 1st row only
    If sh11 <> "" Then ws2.Range("Y" & lr2).Value = get_language(sh11)
  
    '13. Primary Location, first row only
    ws2.Range("AI" & lr2).Value = sh8
  
    '13.1 Pricing enabled
    ws2.Range("Z" & lr2).Value = Sh24
    ws2.Range("AA" & lr2).Value = sh12
  
   '14. Add last row for evaluation
    ws2.Range("BW" & lr2 + cRow).Value = "Media-6-13657"
    ws2.Range("BX" & lr2 + cRow).Value = "LIP/LV/LR Evaluation"
    ws2.Range("BY" & lr2 + cRow).Value = "Evaluation"
  
    'get next batch of row for fill
    If sh13 = "No" Then
        lr2 = lr2 + cRow + 1
    ElseIf sh13 = "Yes" Then
        lr2 = lr2 + cRow + 2
    End If

 

[Peter_SSs]

When posting code, please use code tags to preserve the formatting of the code. See my signature block below for more details. I have added the tags in your post this time.

I have not studied your long code but you should not need to loop to put in a series of weekday dates as Excel has a built-in ability to do that.
Here is a code snippet that puts the weekdays you gave as an example into column BA, starting at row 2. See if you can adapt that for your code.

BTW, I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Sub Weekday_Sequence()
  Dim StartDate As Date, EndDate As Date
  
  StartDate = DateValue("12 Oct 2020")
  EndDate = DateValue("22 Oct 2020")
  With Range("BA2")
    .Value = StartDate
    .DataSeries xlColumns, xlChronological, xlWeekday, 1, EndDate
  End With
End Sub

 

[janki6566]

When posting code, please use code tags to preserve the formatting of the code. See my signature block below for more details. I have added the tags in your post this time.

I have not studied your long code but you should not need to loop to put in a series of weekday dates as Excel has a built-in ability to do that.
Here is a code snippet that puts the weekdays you gave as an example into column BA, starting at row 2. See if you can adapt that for your code.

BTW, I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

Sub Weekday_Sequence()
  Dim StartDate As Date, EndDate As Date
 
  StartDate = DateValue("12 Oct 2020")
  EndDate = DateValue("22 Oct 2020")
  With Range("BA2")
    .Value = StartDate
    .DataSeries xlColumns, xlChronological, xlWeekday, 1, EndDate
  End With
End Sub

Hi Peter_SS

This was amazing !!! sorry about the improper posting, I have not had to code for work in a long time and so just getting back into the proper way. I do have an additional question that maybe you can help, the code provided works perfect but won't include Fridays...is Friday considered a weekend ? I m using MS Office 365

 

[janki6566]

Hi Peter_SS

This was amazing !!! sorry about the improper posting, I have not had to code for work in a long time and so just getting back into the proper way. I do have an additional question that maybe you can help, the code provided works perfect but won't include Fridays...is Friday considered a weekend ? I m using MS Office 365

To be clear, I need it to include Friday.

 

[Peter_SSs]

It includes Friday for me. Here is my test sheet after running the exact code from post #2. All I have done then is manually formatted column BA to "dddd, d mmmm yyyy"

Exactly what results do you get with that code?

20 10 24.xlsm
	BA
1
2	Monday, 12 October 2020
3	Tuesday, 13 October 2020
4	Wednesday, 14 October 2020
5	Thursday, 15 October 2020
6	Friday, 16 October 2020
7	Monday, 19 October 2020
8	Tuesday, 20 October 2020
9	Wednesday, 21 October 2020
10	Thursday, 22 October 2020
11
Date seq vba

 

[janki6566]

It includes Friday for me. Here is my test sheet after running the exact code from post #2. All I have done then is manually formatted column BA to "dddd, d mmmm yyyy"

Exactly what results do you get with that code?

20 10 24.xlsm
	BA
1
2	Monday, 12 October 2020
3	Tuesday, 13 October 2020
4	Wednesday, 14 October 2020
5	Thursday, 15 October 2020
6	Friday, 16 October 2020
7	Monday, 19 October 2020
8	Tuesday, 20 October 2020
9	Wednesday, 21 October 2020
10	Thursday, 22 October 2020
11
Date seq vba

The problem I have is the dates can vary so if it ends on a Friday then it won't include the Friday. I tried adding to the "EndDate +1" and it still won't include the Friday.

So if my date changes from 10/12/2020 (which is a Monday) and ends 10/23/2020 (Friday) then it won't include the Friday.

Thanks for your help in advance

 

[Peter_SSs]

So if my date changes from 10/12/2020 (which is a Monday) and ends 10/23/2020 (Friday) then it won't include the Friday.

Friday is included for me.

Code:

Sub Weekday_Sequence()
  Dim StartDate As Date, EndDate As Date
  
  StartDate = DateValue("12 Oct 2020")
  EndDate = DateValue("23 Oct 2020")
  With Range("BA2")
    .Value = StartDate
    .DataSeries xlColumns, xlChronological, xlWeekday, 1, EndDate
  End With
End Sub

Result:

20 10 24.xlsm
	BA
1
2	Monday, 12 October 2020
3	Tuesday, 13 October 2020
4	Wednesday, 14 October 2020
5	Thursday, 15 October 2020
6	Friday, 16 October 2020
7	Monday, 19 October 2020
8	Tuesday, 20 October 2020
9	Wednesday, 21 October 2020
10	Thursday, 22 October 2020
11	Friday, 23 October 2020
12
Date seq vba

 

[Peter_SSs]

Looking at this thread where you seem to have tried to implement the code I suggested here, it appears that the problem is quite likely that your DataSeries is not just a Date but a Date and a Time.
See if my suggestion there resolves this problem too.

 

[janki6566]

Looking at this thread where you seem to have tried to implement the code I suggested here, it appears that the problem is quite likely that your DataSeries is not just a Date but a Date and a Time.
See if my suggestion there resolves this problem too.

this worked perfectly!! thank you

 

[Peter_SSs]

You're welcome. It would be best if you also posted something in that thread so that the other helper in that thread and/or other readers know if it is resolved.