I'm trying to build an Excel workbook to automate and aid in the creation of a weekly work schedule.
My current workbook is functional, but it's slow - especially on one task where I have a list of people with an annual schedule that I'm searching two sheets at the same time.
I think there's a better and more efficient way than the one I'm using.
Option Explicit
'Global variable that will be in another module where I store all general config
Public Const PlanningAgentEmptyRange As String = "C12:G58,F74:G78" 'Range agent present
Public Const PosteWeekDayRange As String = "B12:B72" 'Range agent present
Public Const PosteWeekEndRange As String = "B73:B78" 'Range agent present
Sub DraftFromCycle()
'If range is empty (to prevent the lost of approved schedule)
If Application.WorksheetFunction.CountA(Range(PlanningAgentEmptyRange)) = 0 Then
'list of day/col Weekday in weekly schedule
Dim aWeekDay(1 To 5) As String
aWeekDay(1) = "C": aWeekDay(2) = "D": aWeekDay(3) = "E": aWeekDay(4) = "F": aWeekDay(5) = "G"
'List of day/col weekEnd in weekly schedule
Dim aWeekEnd(1 To 2) As String
aWeekEnd(1) = "F": aWeekEnd(2) = "G"
Dim DayDate As Range
Dim cel As Range
Dim Col As Variant
Dim DayRangeCycle As Range
Dim DayCycleCol As String
Dim DayCycleRow As Integer
Dim AgentName
Dim p, s, poste, x As Variant
Dim Cycle_lastrow As Integer
Dim Cycle_lastcol As String
Cycle_lastrow = LastRow(Feuil55)
Cycle_lastcol = lastCol(Feuil55)
'Loop col/Day of weekday
For Each Col In aWeekDay
Set DayDate = Range(Col & "11")
Set s = Worksheets("Cycle").Range("A5:OA5").Find(What:=DayDate, Lookat:=xlWhole)
If Not s Is Nothing Then
DayCycleCol = ColLetter(s.Column)
For Each poste In Worksheets("Cycle").Range(DayCycleCol & "6:" & DayCycleCol & Cycle_lastrow)
Select Case poste
Case Is = "AM"
Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="Après-midi", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "N"
Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="Nuit", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "R N"
Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="Récup Nuit", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "R Av"
Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="R.H. Avant Garde", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "R Ap"
Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="R.H. Après Garde", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "RTP"
Set x = ActiveSheet.Range(PosteWeekDayRange).Find(What:="R.T.P.", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekDayRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Else
End Select
Next poste
End If
Next Col
'Loop col du Week End
For Each Col In aWeekEnd
Set DayDate = Range(Col & "73")
Set s = Worksheets("Cycle").Range("A5:OA5").Find(What:=DayDate, Lookat:=xlWhole)
If Not s Is Nothing Then
DayCycleCol = ColLetter(s.Column)
For Each poste In Worksheets("Cycle").Range(DayCycleCol & "6:" & DayCycleCol & Cycle_lastrow)
Select Case poste
Case Is = "AM"
Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="Après-midi", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "N"
Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="Nuit", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "6h25"
Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="6h25 - 13h25", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "7h30"
Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="7h30 - 14h30", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Is = "7h45"
Set x = ActiveSheet.Range(PosteWeekEndRange).Find(What:="7h45 - 14h45", Lookat:=xlWhole)
If Not x Is Nothing Then
Do
If ActiveSheet.Range(Col & x.row) = "" Then
ActiveSheet.Range(Col & x.row) = Worksheets("Cycle").Range("A" & poste.row).value
ActiveSheet.Range(Col & x.row).Font.Italic = True
End If
Set x = ActiveSheet.Range(PosteWeekEndRange).FindNext(x)
Loop While Not x Is Nothing
End If
Case Else
End Select
Next poste
End If
Next Col
End If
End Sub
Here's a screen of what the sheets look like the module take the data from the annual schedule and autofilled the weekly schedule if it's empty
Annual Schedule (Worksheets("Cycle"))
Weekly Schedule (Worksheets("1"))
