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

J

janki6566

New Member
Joined
Sep 24, 2014
Messages
21
Office Version
  1. 365
Platform
  1. Windows
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.


VBA Code: 
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
 
Last edited by a moderator:
Sort by date Sort by votes
janki6566 said:
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
Click to expand...
this worked perfectly !
 
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
You must log in or register to reply here.

Similar threads

J
  • Question Question
VBA Fill Series Weekdays trying to paste same date twice before moving to next date
2
Replies
10
Views
2K
Peter_SSs
Peter_SSs
J
  • Question Question
Data Series for Dates not including Fridays
Replies
0
Views
506
janki6566
J
Johnny Thunder
  • Question Question
VBA Revision - Value is Text but gets pasted as a date?
Replies
5
Views
543
Snakehips
Snakehips
Etv5002
  • Question Question
Grouping together Sheets to create multiple pdfs
Replies
1
Views
532
Etv5002
Etv5002

Forum statistics

Threads
1,223,893
Messages
6,175,241
Members
452,622
Latest member
Laura_PinksBTHFT

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top