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

J

janki6566

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

VBA Code: 
'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.


Screenshot 2020-10-25 214629.png
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
Sort by date Sort by votes
This script looks to be doing a lot more then just entering some dates in a range.
It looks like your dealing with numerous sheets.

I see nothing here that tells the script the start and end dates.

If all you wanted to do was enter some dates in a range why do you need all this code.
 
Upvote 0
My Aswer Is This said:
I see nothing here that tells the script the start and end dates.
Click to expand...
It appears to be the setting of variables sh9 and sh10

@janki6566
Firstly a couple of comments.
  • It is always difficult to debug code when you are only given part of it. Best to post it all if possible but explain where the problem part is.
  • You need to be careful with your sample data. You describe pasting all dates twice but you have shown 12 Oct and 23 Oct three times each and 13 Oct only once.
  • Your sample data shows dates only but your code appears to be trying use Date and Time values. You may need to clarify whether you do in fact want Date/Time or just Date.

Assuming that you do want Date/Time try modifying the last part of your displayed code like this.

Rich (BB code): 
       If sh25 = "CoTeach" Then
            With ws2.Range("BA" & lr2)
                .Value = DateValue(sh9) + (Sh14)
                .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10 + 1), False
                .Value = sh9 + Sh14
                .DataSeries xlColumns, xlChronological, xlWeekday, 1, sh10 + Sh15, False
            End With
            With ws2.Range("BA" & lr2, ws2.Range("BA" & lr2).End(xlDown))
              .Copy Destination:=.Offset(.Rows.Count)
              .Resize(.Rows.Count * 2).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
            End With
 
Upvote 0
Peter_SSs said:
It appears to be the setting of variables sh9 and sh10

@janki6566
Firstly a couple of comments.
  • It is always difficult to debug code when you are only given part of it. Best to post it all if possible but explain where the problem part is.
  • You need to be careful with your sample data. You describe pasting all dates twice but you have shown 12 Oct and 23 Oct three times each and 13 Oct only once.
  • Your sample data shows dates only but your code appears to be trying use Date and Time values. You may need to clarify whether you do in fact want Date/Time or just Date.

Assuming that you do want Date/Time try modifying the last part of your displayed code like this.

Rich (BB code): 
       If sh25 = "CoTeach" Then
            With ws2.Range("BA" & lr2)
                .Value = DateValue(sh9) + (Sh14)
                .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10 + 1), False
                .Value = sh9 + Sh14
                .DataSeries xlColumns, xlChronological, xlWeekday, 1, sh10 + Sh15, False
            End With
            With ws2.Range("BA" & lr2, ws2.Range("BA" & lr2).End(xlDown))
              .Copy Destination:=.Offset(.Rows.Count)
              .Resize(.Rows.Count * 2).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
            End With
Click to expand...
Hello ! Thank you again for being so patient with me! My apologies on the sample data. The code is pretty large so I didn't want to over do it. Again, sorry!

I tried this code and its close but I am running into a couple of issues and I am not sure what route to take. I have tried a variation of things and just don't seem to get it to that point.

I will paste here in a bit the entire code but essentially the code is pulling from worksheet 1 the date and time value which I fixed into on cell. Then it its is meant to run through a loop in which if the teach type is Co-Teach, then the number of days between the start date and end date should be represented twice so essentially a 10 day class would have 20 rows of data, then dates are suppose to repeat twice as shown above and yes you are correct my sample data for date 10/23/2020 should have only been done twice.

I tested the code provide and it takes the last day and run through twice instead of each date. Here is what I am getting:


1603752822151.png


In an attempt to run through it and try to change the code, I tried changing the Resize (.Row.Count*2) to Resize (.Row.Count *.5) and it did this and errored.
1603752936188.png



I tried many other variations that also errored, I am just not sure where I am going wrong. In effort, I have pasted my entire code but we are focusing on section 3 for time
VBA Code: 
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("X" & 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 courses
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
        If Sh25 = "T3" And rLoop = cRow - 1 Then
           ws2.Range("AO" & rLoop + lr2).Value = rLoop
           ws2.Range("AQ" & rLoop + lr2).Value = rLoop
        Else
           ws2.Range("AO" & rLoop + lr2).Value = rLoop + 1
           ws2.Range("AQ" & rLoop + lr2).Value = rLoop + 1
        End If


        
        '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
       If Sh25 = "CoTeach" Then
                With ws2.Range("BA" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh9)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh9), False
                End With
                With ws2.Range("BB" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh10)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh10), False
                 End With
                With ws2.Range("BA" & lr2, ws2.Range("BA" & lr2)).End((xlDown))
                    .Copy Destination:=.Offset(.Rows.Count)
                    .Resize(.Rows.Count * 0.5).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
                 End With
                With ws2.Range("BB" & lr2, ws2.Range("BB" & lr2)).End((xlDown))
                    .Copy Destination:=.Offset(.Rows.Count)
                    .Resize(.Rows.Count * 2).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
                 End With
        Else
            If Sh25 = "T3" And rLoop = cRow - 1 Then
                 With ws2.Range("BA" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh9)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh9), False
                    ws2.Range("BA" & cRow + lr2 - 1).Value = DateValue(sh10) + TimeValue(sh9)
                 End With
                  With ws2.Range("BB" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh10)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh10), False
                    ws2.Range("BB" & cRow + lr2 - 1).Value = DateValue(sh10) + TimeValue(sh10)
                 End With
            Else
                With ws2.Range("BA" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh9)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh9), False
                 End With
                With ws2.Range("BB" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh10)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh10), False
                 End With
            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 = "https://ondemand.questionmark.com/home/405715/"
            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

any help would be greatly appreciated!
 
Upvote 0
Just a comment from me.
I prefer users tell me with specifics what they want accomplished and let me write the code.
Showing me a hundred lines of your code does not help me much it drains my brain trying to read all the code and sort out what needs to be changed since the code the user is using does not work for the user.

When I say specifics I mean:
Column numbers like column B
Sheet names like sheet named "Alpha"
Do not say column Dates or Sheet(1)

Just my thoughts.
 
Upvote 0
janki6566 said:
Hello ! Thank you again for being so patient with me! My apologies on the sample data. The code is pretty large so I didn't want to over do it. Again, sorry!

I tried this code and its close but I am running into a couple of issues and I am not sure what route to take. I have tried a variation of things and just don't seem to get it to that point.

I will paste here in a bit the entire code but essentially the code is pulling from worksheet 1 the date and time value which I fixed into on cell. Then it its is meant to run through a loop in which if the teach type is Co-Teach, then the number of days between the start date and end date should be represented twice so essentially a 10 day class would have 20 rows of data, then dates are suppose to repeat twice as shown above and yes you are correct my sample data for date 10/23/2020 should have only been done twice.

I tested the code provide and it takes the last day and run through twice instead of each date. Here is what I am getting:


View attachment 24938

In an attempt to run through it and try to change the code, I tried changing the Resize (.Row.Count*2) to Resize (.Row.Count *.5) and it did this and errored.
View attachment 24939


I tried many other variations that also errored, I am just not sure where I am going wrong. In effort, I have pasted my entire code but we are focusing on section 3 for time
VBA Code: 
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("X" & 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 courses
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
        If Sh25 = "T3" And rLoop = cRow - 1 Then
           ws2.Range("AO" & rLoop + lr2).Value = rLoop
           ws2.Range("AQ" & rLoop + lr2).Value = rLoop
        Else
           ws2.Range("AO" & rLoop + lr2).Value = rLoop + 1
           ws2.Range("AQ" & rLoop + lr2).Value = rLoop + 1
        End If


       
        '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
       If Sh25 = "CoTeach" Then
                With ws2.Range("BA" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh9)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh9), False
                End With
                With ws2.Range("BB" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh10)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh10), False
                 End With
                With ws2.Range("BA" & lr2, ws2.Range("BA" & lr2)).End((xlDown))
                    .Copy Destination:=.Offset(.Rows.Count)
                    .Resize(.Rows.Count * 0.5).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
                 End With
                With ws2.Range("BB" & lr2, ws2.Range("BB" & lr2)).End((xlDown))
                    .Copy Destination:=.Offset(.Rows.Count)
                    .Resize(.Rows.Count * 2).Sort Key1:=.Cells(1), Order1:=xlAscending, Header:=xlNo
                 End With
        Else
            If Sh25 = "T3" And rLoop = cRow - 1 Then
                 With ws2.Range("BA" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh9)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh9), False
                    ws2.Range("BA" & cRow + lr2 - 1).Value = DateValue(sh10) + TimeValue(sh9)
                 End With
                  With ws2.Range("BB" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh10)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh10), False
                    ws2.Range("BB" & cRow + lr2 - 1).Value = DateValue(sh10) + TimeValue(sh10)
                 End With
            Else
                With ws2.Range("BA" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh9)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh9), False
                 End With
                With ws2.Range("BB" & lr2)
                    .Value = DateValue(sh9) + TimeValue(sh10)
                    .DataSeries xlColumns, xlChronological, xlWeekday, 1, DateValue(sh10) + TimeValue(sh10), False
                 End With
            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 = "https://ondemand.questionmark.com/home/405715/"
            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

any help would be greatly appreciated!
Click to expand...
And only need help in the section for section 3 for the IF sh25 = "CoTeach" then section, anything after If sh25 ="t3" is good. Thank you so much for any guidance you can provide.
 
Upvote 0
So that I can be fairly sure I am using similar data ...
Let's assume
  • xLoop = 3 so we are looking in row 3 on ws1
  • Sh25 = "CoTeach"

Given that, can you answer the following questions about ws1?
  1. What is in cell U3 and is it text or numerical? If unsure what does this formula return? =ISNUMBER(U3)
  2. What is in cell X3 and is it text or numerical?

Can I also suggest that you investigate XL2BB for providing (small) sample data to make it easier for helpers by not having to manually type out sample data to test with.
 
Upvote 0
Peter_SSs said:
So that I can be fairly sure I am using similar data ...
Let's assume
  • xLoop = 3 so we are looking in row 3 on ws1
  • Sh25 = "CoTeach"

Given that, can you answer the following questions about ws1?
  1. What is in cell U3 and is it text or numerical? If unsure what does this formula return? =ISNUMBER(U3)
  2. What is in cell X3 and is it text or numerical?
Click to expand...
Peter_SSs said:
So that I can be fairly sure I am using similar data ...
Let's assume
  • xLoop = 3 so we are looking in row 3 on ws1
  • Sh25 = "CoTeach"

Given that, can you answer the following questions about ws1?
  1. What is in cell U3 and is it text or numerical? If unsure what does this formula return? =ISNUMBER(U3)
  2. What is in cell X3 and is it text or numerical?

Can I also suggest that you investigate XL2BB for providing (small) sample data to make it easier for helpers by not having to manually type out sample data to test with.
Click to expand...
Hello

Yes, the assumptions are correct.

answer for ws1
1 and 2: no its formula that makes a date and time value from two other columns

trying the xxlb here where the dates are pulling from

Course Offering - Copy.xlsm
UVWXYZ
1Start Date*End Date*End Date*
2StartDate of class startTime of class startEnd Date*Date of class endTime of class end
310/12/20 9:00:0010/12/20209:00:00 AM10/22/20 14:00:0010/22/20202:00:00 PM
410/12/20 9:00:0010/12/20209:00:00 AM10/22/20 14:00:0010/22/20202:00:00 PM
510/12/20 9:00:0010/12/20209:00:00 AM10/23/20 14:00:0010/23/20202:00:00 PM
610/12/20 9:00:0010/12/20209:00:00 AM10/23/20 14:00:0010/23/20202:00:00 PM
Delivery Template
Cell Formulas
RangeFormula
U3:U6,X3:X6U3=TEXT(V3,"m/dd/yy ")&TEXT(W3,"h:mm:ss")
 
Upvote 0
janki6566 said:
Hello

Yes, the assumptions are correct.

answer for ws1
1 and 2: no its formula that makes a date and time value from two other columns

trying the xxlb here where the dates are pulling from

Course Offering - Copy.xlsm
UVWXYZ
1Start Date*End Date*End Date*
2StartDate of class startTime of class startEnd Date*Date of class endTime of class end
310/12/20 9:00:0010/12/20209:00:00 AM10/22/20 14:00:0010/22/20202:00:00 PM
410/12/20 9:00:0010/12/20209:00:00 AM10/22/20 14:00:0010/22/20202:00:00 PM
510/12/20 9:00:0010/12/20209:00:00 AM10/23/20 14:00:0010/23/20202:00:00 PM
610/12/20 9:00:0010/12/20209:00:00 AM10/23/20 14:00:0010/23/20202:00:00 PM
Delivery Template
Cell Formulas
RangeFormula
U3:U6,X3:X6U3=TEXT(V3,"m/dd/yy ")&TEXT(W3,"h:mm:ss")
Click to expand...
Let me clarify xLoop starts at row 3 ws1 and loops through each line to create a set of data in ws2. If there was a way to send you a attachment and thats easier. let me know.
 
Upvote 0
Just a heads up, I figured this out with following code, but thank you so much for your help!!!! Peter_SS you are so awesome!!!

VBA Code: 
  If sh25 = "CoTeach" Then
           If Application.WorksheetFunction.IsEven(rLoop + 2) Then
                MyCount = Application.WorksheetFunction.RoundDown((rLoop + 1) / 2, 0)
                With ws2.Range("BA" & rLoop + lr2)
                    
                    MyWeekDay = Weekday(DateValue(sh9 + MyCount) + TimeValue(sh9))
                    If MyWeekDay >= 2 And MyWeekDay <= 6 Then
                        If AreWeInWeek2 = False Then
                           .Value = DateValue(sh9 + MyCount) + TimeValue(sh9)
                        Else
                            
                           .Value = DateValue(sh9 + MyCount + 2) + TimeValue(sh9)
                        End If

                    Else
                        ' the day is either Saturday or Sunday
                        .Value = DateValue(sh9 + MyCount + 2) + TimeValue(sh9)
                        If MyWeekDay = 7 Then
                            AreWeInWeek2 = True
                        End If
                    End If
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
Loop through a start and end date, paste only weekdays in VBA
2
Replies
10
Views
4K
janki6566
J
J
  • Question
Data Series for Dates not including Fridays
Replies
0
Views
406
janki6566
J
Etv5002
  • Question
Grouping together Sheets to create multiple pdfs
Replies
1
Views
463
Etv5002
Etv5002

Forum statistics

Threads
1,214,647
Messages
6,120,722
Members
448,987
Latest member
marion_davis

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