VBA Code to split week ranges into separate lines.

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hello everyone

Right I have a problem that I just can’t solve. I’ve posted something similar before and someone suggested power query but I don’t know it, never used it (although I will do as it looks great) but I have a big scheduling job and not much time so a VBA solution would be the best option for now.

So I have a workbook and there are 3 Sheets

Sheet 1 is a extract of a 1000+ line spreadsheet that I need to split into individual lines based on the data in Column F which relates to week numbers in which teaching is going to take place.

20210923 - Data Download from Timetabling System.xlsx
ABCDEFGHIJKL
1ReferenceCourse NameRoom NumberLocationAllocated TeacherScheduled WeeksScheduled DaysPlanned SizeSizeScheduled Start TimeScheduled End TimeDuration
20001Course 123LondonTeacher 11, 5, 8-9Tuesday009:0010:0001:00
30002Course 224BirminghamTeacher 23-5, 10-12, 16, 19Wednesday009:0010:0001:00
40003Course 328ManchesterTeacher 317, 22Tuesday009:0010:0001:00
50004Course 423LondonTeacher 48Tuesday009:0010:0001:00
60005Course 523LondonTeacher 53Tuesday009:0010:0001:00
Sheet1


The data in COLUMN F is in the format of week numbers so you will see that it can be entered as a week range e.g. 1-5 or Singles weeks like 1, or several weeks 1,5,6 or a combination of these. So you will see in the example below, COLUMN F3 shows 3-5, 10-12, 16, 19

So Course 2 is being taught on a Wednesday on weeks 3 to 5 and then weeks 10-12 and then on week 16 and week 19.

Sheet 2 contains a list of all week numbers and dates which Sheet 1 should reference

20210923 - Data Download from Timetabling System.xlsx
ABCDEF
1Week No.MondayTuesdayWednesdayThursdayFriday
2127/9/202128/9/202129/9/202130/9/20211/10/2021
324/10/20215/10/20216/10/20217/10/20218/10/2021
4311/10/202112/10/202113/10/202114/10/202115/10/2021
5418/10/202119/10/202120/10/202121/10/202122/10/2021
6525/10/202126/10/202127/10/202128/10/202129/10/2021
761/11/20212/11/20213/11/20214/11/20215/11/2021
878/11/20219/11/202110/11/202111/11/202112/11/2021
9815/11/202116/11/202117/11/202118/11/202119/11/2021
10922/11/202123/11/202124/11/202125/11/202126/11/2021
111029/11/202130/11/20211/12/20212/12/20213/12/2021
12116/12/20217/12/20218/12/20219/12/202110/12/2021
131213/12/202114/12/202115/12/202116/12/202117/12/2021
141320/12/202121/12/202122/12/202123/12/202124/12/2021
151427/12/202128/12/202129/12/202130/12/202131/12/2021
16153/1/20224/1/20225/1/20226/1/20227/1/2022
171610/1/202211/1/202212/1/202213/1/202214/1/2022
181717/1/202218/1/202219/1/202220/1/202221/1/2022
191824/1/202225/1/202226/1/202227/1/202228/1/2022
201931/1/20221/2/20222/2/20223/2/20224/2/2022
21207/2/20228/2/20229/2/202210/2/202211/2/2022
222114/2/202215/2/202216/2/202217/2/202218/2/2022
232221/2/202222/2/202223/2/202224/2/202225/2/2022
242328/2/20221/3/20222/3/20223/3/20224/3/2022
25247/3/20228/3/20229/3/202210/3/202211/3/2022
262514/3/202215/3/202216/3/202217/3/202218/3/2022
272621/3/202222/3/202223/3/202224/3/202225/3/2022
282728/3/202229/3/202230/3/202231/3/20221/4/2022
29284/4/20225/4/20226/4/20227/4/20228/4/2022
302911/4/202212/4/202213/4/202214/4/202215/4/2022
313018/4/202219/4/202220/4/202221/4/202222/4/2022
323125/4/202226/4/202227/4/202228/4/202229/4/2022
33322/5/20223/5/20224/5/20225/5/20226/5/2022
34339/5/202210/5/202211/5/202212/5/202213/5/2022
353416/5/202217/5/202218/5/202219/5/202220/5/2022
363523/5/202224/5/202225/5/202226/5/202227/5/2022
373630/5/202231/5/20221/6/20222/6/20223/6/2022
38376/6/20227/6/20228/6/20229/6/202210/6/2022
393813/6/202214/6/202215/6/202216/6/202217/6/2022
403920/6/202221/6/202222/6/202223/6/202224/6/2022
414027/6/202228/6/202229/6/202230/6/20221/7/2022
42414/7/20225/7/20226/7/20227/7/20228/7/2022
434211/7/202212/7/202213/7/202214/7/202215/7/2022
444318/7/202219/7/202220/7/202221/7/202222/7/2022
454425/7/202226/7/202227/7/202228/7/202229/7/2022
46451/8/20222/8/20223/8/20224/8/20225/8/2022
47468/8/20229/8/202210/8/202211/8/202212/8/2022
484715/8/202216/8/202217/8/202218/8/202219/8/2022
494822/8/202223/8/202224/8/202225/8/202226/8/2022
504929/8/202230/8/202231/8/20221/9/20222/9/2022
51505/9/20226/9/20227/9/20228/9/20229/9/2022
525112/9/202213/9/202214/9/202215/9/202216/9/2022
535219/9/202220/9/202221/9/202222/9/202223/9/2022
Sheet2
Cell Formulas
RangeFormula
C2:F53C2=B2+1


Sheet 3 is the output that I want the Macro to produce

20210923 - Data Download from Timetabling System.xlsx
ABCDEFGHIJKL
1ReferenceCourse NameRoom NumberLocationAllocated TeacherDelivery DatesScheduled DaysPlanned SizeSizeScheduled Start TimeScheduled End TimeDuration
20001Course 123LondonTeacher 128/9/2021Tuesday009:0010:0001:00
30001Course 123LondonTeacher 125/10/2021Tuesday009:0010:0001:00
40001Course 123LondonTeacher 116/11/2021Tuesday009:0010:0001:00
50001Course 123LondonTeacher 123/11/2021Tuesday009:0010:0001:00
60002Course 224BirminghamTeacher 213/10/2021Wednesday009:0010:0001:00
70002Course 224BirminghamTeacher 220/10/2021Wednesday009:0010:0001:00
80002Course 224BirminghamTeacher 227/10/2021Wednesday009:0010:0001:00
90002Course 224BirminghamTeacher 21/12/2021Wednesday009:0010:0001:00
100002Course 224BirminghamTeacher 28/12/2021Wednesday009:0010:0001:00
110002Course 224BirminghamTeacher 215/12/2021Wednesday009:0010:0001:00
120002Course 224BirminghamTeacher 212/1/2022Wednesday009:0010:0001:00
130002Course 224BirminghamTeacher 22/2/2022Wednesday009:0010:0001:00
140003Course 328ManchesterTeacher 320/1/2022Thursday009:0010:0001:00
Sheet 3


So sticking with the Course 2 example above I need the output to reproduce the date on Sheet 1, but to split out each teaching session onto a separate line so each week of teaching has it’s own line. So in this case the lines are:

Week 3 - 13-Oct-21

Week 4 – 20-Oct-21

Week 5 – 27-Oct-21

Week 10 – 1-Dec-21

Week 11 – 8-Dec-21

Week 12 – 15-Dec-21

Week 16 – 12-Jan-22

Week 19 - 2-Feb-22

So COLUMN F contains a date not a week range.

I have to submit this by 9am on Monday and it’s just going to be impossible to split it out manually. Can anyone help with some code to do this?
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
OK if it it makes it easier I can change the week ranges to be in the same format i.e. 1, 5, 6, 8, 9, 10, 11, 12, 23, 26 so it's always just a series of numbers rather than a combination of numbers and ranges.
 

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
sometimes it will be just a single number
 

EXCEL MAX

Well-known Member
Joined
Nov 11, 2020
Messages
508
Office Version
  1. 2016
Platform
  1. Windows
You can test this one...
VBA Code:
Sub SplitWeekRanges()

    Dim vWS1 As Worksheet, vWS2 As Worksheet, vWS3 As Worksheet
    Dim vA1, vA2(), vA3()
    Dim vS, vSS
    Dim vN As Long, vN1 As Long, vN2 As Long, vN3 As Long
    Dim vR As Long, vNR As Long, vX As Long
    Dim vD As Integer
    Dim vT As String
    
    Set vWS1 = Sheets("Sheet1")
    Set vWS2 = Sheets("Sheet2")
    Set vWS3 = Sheets("Sheet3")
    vR = 1
    vA1 = vWS1.UsedRange
    ReDim vA3(UBound(vA1) - 1)
    ReDim vA2(UBound(vA1) - 1)
    For vN = 2 To UBound(vA1)
        vS = Split(vA1(vN, 6), ",")
        vT = Mid(Replace(SplitWeeks(vS), " ", ""), 2)
        vNR = vNR + UBound(Split(vT, ",")) + 1
        vA2(vN - 1) = vT
    Next vN
    ReDim vA3(1 To vNR + 1, 1 To 12)
    For vN = 2 To UBound(vA1)
        vT = vA1(vN, 7)
        vD = vWS2.Rows(1).Find(vT).Column
        For vN2 = 1 To UBound(Split(vA2(vN - 1), ",")) + 1
            vR = vR + 1
            vT = Application.Index(vWS2.UsedRange, _
                  Split(vA2(vN - 1), ",")(vN2 - 1) + 1, vD)
            For vN3 = 1 To 5
                   vA3(vR, vN3) = vA1(vN, vN3)
            Next vN3
            vA3(vR, 6) = vT
            For vN3 = 7 To 12
                   vA3(vR, vN3) = vA1(vN, vN3)
            Next vN3
        Next
    Next vN
    vWS3.Cells.ClearContents
    vWS3.[A1].Resize(UBound(vA3), 12) = vA3
    With vWS3
        .Range("J2:L" & vNR + 1).NumberFormat = "hh:mm"
        .Range("F2:F" & vNR + 1).NumberFormat = "mm-dd-yy"
        vWS1.[A1:L1].Copy .[A1:L1]
        .[F1] = "Delivery Dates"
    End With
    
End Sub

Function SplitWeeks(ByVal vS)
        
        For vN1 = 0 To UBound(vS)
            If InStr(1, vS(vN1), "-") Then
                vSS = Split(vS(vN1), "-")
                vX = vSS(1) - vSS(0) + 1
                For vN2 = 1 To vX
                    vT = vT & "," & vSS(0) - 1 + vN2
                Next vN2
                GoTo EX
            End If
             vT = vT & "," & vS(vN1)
EX:  Next vN1
        SplitWeeks = vT
        
End Function
 
Solution

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

Works perfectly - thanks very much mate. You have saved my Sunday!
 

EXCEL MAX

Well-known Member
Joined
Nov 11, 2020
Messages
508
Office Version
  1. 2016
Platform
  1. Windows
Seems like a nice day to enjoy weekend. Go for it. ;)
 

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS

ADVERTISEMENT

Thanks I just posted another query re identifying clashes in scheduling as having gone through the raw data last night it seems there is quite a few. Thanks for your help and enjoy your Sunday too.
Mark
 

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Hey mate - thanks for this and thanks to your reply to my other thread that I need to test still. I'm trying this macro and it keeps tripping up at the following point on my real data : vD = vWS2.Rows(1).Find(vT).Column can you confirm what this relates to? I've tried a few things to clean up data but it doesn't work. Thanks very much. Mark
 

markster

Well-known Member
Joined
May 23, 2002
Messages
568
Office Version
  1. 365
Platform
  1. Windows
  2. MacOS
Mate don't worry it's definitely my data. I need to pinpoint the problem. Cheers and thanks again for everything
 

Forum statistics

Threads
1,147,482
Messages
5,741,409
Members
423,658
Latest member
Kumaradas

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
Top