VBA Fill Series Weekdays trying to paste same date twice before moving to next date

[janki6566]

Hello,

I have a macro in which I need to fill column BA via a loop with start to end dates and it should only include weekdays. So essentially, my dates can change but for example I have start date of 10/12/2020 to 10/23/2020 but I need them to enter each date twice before moving on to the next date.

'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
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, i As Long
Dim sh3 As Integer, sh4 As Integer
Dim sh9 As Date, sh10 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), "_", " ")
  
      
        '3. Same date, Start time
       If sh25 = "CoTeach" Then
            With ws2.Range("BA" & lr2)
                .Value = DateValue(sh9) + (Sh14)
                .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10 + 1), False
            End With

The below is a screenshot of what I need my code to do, which is paste each date twice.

 

[Peter_SSs]

You're welcome. Glad you got it sorted.