VBA shift scheduler

ssm84

New Member
Joined
Jun 15, 2020
Messages
25
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
  2. Mobile
Hello everyone!
I'm here to humbly ask for your help on VBA ... considering I'm still sooo impractical about VBA .....
I'm trying to create a staff shift scheduler.
I thought it was a simple project .... but I guess I ran aground ....
As per attached file, I hypothesized a H24 7 days a week system. which are repeated month by month (clearly dynamically and not statically)
The system repeats the following way
1= PP RR NN RR M M
2= RR MM PP RR N N
3= NN RR MM PP RR
4= MM PP RR N N RR
5= RR NN RR MM PP

where P= Pomeridian
R= Rest
N= Night
M= Mornings
so, 1= 2 days of pomeridian, 2 days rest, 2 nights, 2 rest, 2 mornings....rinse and repeat lol


The part of the code, on the other hand, which should write the shifts on all the lines does not work ... I select the shift of group 1 it writes the relative shift only on the first line ... I started writing the code where I automatically enter dates / gg, and so far everything is fine. I did not understand how to write...


VBA Code:
Sub ins1()
Dim ID As Integer

Range("D6").Select
Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
ID = ActiveCell.Offset(-1, 0).Range("a1") - 37883
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = "P"
Case 2 To 3
ActiveCell.Value = ""
Case 4 To 5
ActiveCell.Value = "N"
Case 6 To 7
ActiveCell.Value = ""
Case 8 To 9
ActiveCell.Value = "M"
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop

Range("D7").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = "P"
Case 2 To 3
ActiveCell.Value = ""
Case 4 To 5
ActiveCell.Value = "N"
Case 6 To 7
ActiveCell.Value = ""
Case 8 To 9
ActiveCell.Value = "M"
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop


Range("D8").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = ""
Case 2 To 3
ActiveCell.Value = "M"
Case 4 To 5
ActiveCell.Value = "P"
Case 6 To 7
ActiveCell.Value = "N"
Case 8 To 9
ActiveCell.Value = ""
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop

Range("D9").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = ""
Case 2 To 3
ActiveCell.Value = "M"
Case 4 To 5
ActiveCell.Value = "P"
Case 6 To 7
ActiveCell.Value = "N"
Case 8 To 9
ActiveCell.Value = ""
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop

Range("D10").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = "N"
Case 2 To 3
ActiveCell.Value = ""
Case 4 To 5
ActiveCell.Value = "M"
Case 6 To 7
ActiveCell.Value = "P"
Case 8 To 9
ActiveCell.Value = ""
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop

Range("D11").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = "N"
Case 2 To 3
ActiveCell.Value = ""
Case 4 To 5
ActiveCell.Value = "M"
Case 6 To 7
ActiveCell.Value = "P"
Case 8 To 9
ActiveCell.Value = ""
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop


Range("D12").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = "M"
Case 2 To 3
ActiveCell.Value = "P"
Case 4 To 5
ActiveCell.Value = ""
Case 6 To 7
ActiveCell.Value = "N"
Case 8 To 9
ActiveCell.Value = ""
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop




Range("D13").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = "M"
Case 2 To 3
ActiveCell.Value = "P"
Case 4 To 5
ActiveCell.Value = ""
Case 6 To 7
ActiveCell.Value = "N"
Case 8 To 9
ActiveCell.Value = ""
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop


Range("D14").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = ""
Case 2 To 3
ActiveCell.Value = "N"
Case 4 To 5
ActiveCell.Value = ""
Case 6 To 7
ActiveCell.Value = "M"
Case 8 To 9
ActiveCell.Value = "P"
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop

Range("D15").Select

Do While ActiveCell.Offset(-1, 0).Range("a1").Value <> ""
Select Case Right(ID, 1)
Case 0 To 1
ActiveCell.Value = ""
Case 2 To 3
ActiveCell.Value = "N"
Case 4 To 5
ActiveCell.Value = ""
Case 6 To 7
ActiveCell.Value = "M"
Case 8 To 9
ActiveCell.Value = "P"
Case Else
MsgBox "Error...You Should never see this"
End Select
ActiveCell.Offset(0, 1).Range("a1").Select
Loop


End Sub



The best solution would be for the code to read the last two days of the previous month and write the new one....but not there yet as knowledge necessary XD

any help?
attached link to sample file
Sample File
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
i've added a function if to select if to start array with a p array or m array.... don't quiet understand the logic of the formula.
Looks like some times it works and other it does not start with what selected......what is the logic in the formula you provided??
VBA Code:
Sub Rows17_19_2()
   
   Dim Ary As Variant, Shft As Variant, WkDays As Variant
   Dim r As Long, c As Long, x As Long, y As Long, z As Long
   Dim Itm As Boolean
    
    'this is the selection i added
    If meccanico = "M" Or meccanico = "m" Then
   Shft = Array("M", "P")
   End If
   
         If meccanico = "P" Or meccanico = "p" Then
         Shft = Array("P", "M")
         
         End If
        
         
         
   r = Range("B17").End(xlDown).Row
   c = Range("D5").End(xlToRight).Column
   Ary = Range("D17", Cells(r, c)).Value
   WkDays = Range("D3", Cells(3, c)).Value
   
   For r = 1 To UBound(Ary) - 1
      Itm = Not Itm
      For c = 1 To UBound(Ary, 2)
         Select Case WkDays(1, c)
            Case 1 To 5
               Ary(r, c) = Shft(-Itm)
            Case 6
               Ary(r, c) = ""
               Itm = Not Itm
            Case Else
               Ary(r, c) = ""
         End Select
      Next c
   Next r
   Range("D17").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
   
End Sub
 
Upvote 0
What is meccanico? From that code it does not have any value.
 
Upvote 0
It is a text value from a form where you write m or p to try and start the array in that manner
 
Upvote 0
Just add this line, to my code
Rich (BB code):
   Itm = meccanico = "M"
   For r = 1 To UBound(Ary) - 1
 
Upvote 0
Just add this line, to my code
Rich (BB code):
   Itm = meccanico = "M"
   For r = 1 To UBound(Ary) - 1

Working ish... need to understand code..
 
Last edited:
Upvote 0
in tests, some months work great, in others i need to write the opposite letter.... I think is due to the fact that some months start on weekends therefore jumps to next series
 
Upvote 0
in tests, some months work great, in others i need to write the opposite letter.... I think is due to the fact that some months start on weekends therefore jumps to next series

by the way, this is how the code looks....just in case a make a newbe mistake

VBA Code:
Sub Rows17_19_2()
   
   Dim Ary As Variant, Shft As Variant, WkDays As Variant
   Dim r As Long, c As Long, x As Long, y As Long, z As Long
   Dim Itm As Boolean
    
    Shft = Array("M", "P")
    
    
    r = Range("B17").End(xlDown).Row
   c = Range("D5").End(xlToRight).Column
   Ary = Range("D17", Cells(r, c)).Value
   WkDays = Range("D3", Cells(3, c)).Value
   
   Itm = meccanico = "M"
   
   For r = 1 To UBound(Ary) - 1
      Itm = Not Itm
      For c = 1 To UBound(Ary, 2)
         Select Case WkDays(1, c)
            Case 1 To 5
               Ary(r, c) = Shft(-Itm)
            Case 6
               Ary(r, c) = ""
               Itm = Not Itm
            Case Else
               Ary(r, c) = ""
         End Select
      Next c
   Next r
   Range("D17").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
   
End Sub
 
Upvote 0
How about
VBA Code:
Sub Rows17_19()
   Dim Ary As Variant, Shft As Variant, WkDays As Variant
   Dim r As Long, c As Long, x As Long, y As Long, z As Long
   Dim Itm As Boolean
   
   Shft = Array("M", "P")
                
   r = Range("B17").End(xlDown).Row
   c = Range("D5").End(xlToRight).Column
   Ary = Range("D17", Cells(r, c)).Value
   WkDays = Range("D3", Cells(3, c)).Value
   
   If WkDays(1, 1) > 5 Then
      Itm = meccanico <> "M"
   Else
      Itm = meccanico = "M"
   End If
   
   For r = 1 To UBound(Ary) - 1
      Itm = Not Itm
      For c = 1 To UBound(Ary, 2)
         Select Case WkDays(1, c)
            Case 1 To 5
               Ary(r, c) = Shft(-Itm)
            Case 6
               Ary(r, c) = ""
               Itm = Not Itm
            Case Else
               Ary(r, c) = ""
         End Select
      Next c
   Next r
   Range("D17").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,532
Messages
6,114,177
Members
448,554
Latest member
Gleisner2

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