VBA shift scheduler

S

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
 
Sort by date Sort by votes
oh! wow!
sorry!
working a beuty!!

Thank you very much!
 
Upvote 0

Excel Facts

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
You're welcome & thanks for the feedback.
 
Upvote 0
Hello, regarding the same file.
on the row 17-19 i am trying to adapt the formula to write mon-fri row 17 letter M row 18 Letter P on a week. the following week it exchanges P on row 17 M on row 18.
The formula works, but do not know how to make it swap on dynamic weeks


VBA Code: 
Sub alternativeweeks()
   Dim Ary As Variant, Shft As Variant
   Dim r As Long, C As Long, x As Long, y As Long, g As Long
  
  
   Shft = Array(Array("M", "P"), _
                Array("P", "M"))
              
  
   r = Range("B17").End(xlDown).Row
   C = Range("D2").End(xlToRight).Column
   Ary = Range("D17", Cells(r, C)).Value
  
      For r = 1 To UBound(Ary)
      For C = 1 To UBound(Ary, 2)
         x = Int((C - 1) / 7) Mod 2
         y = Int((r - 1) / 7) Mod 2
         Ary(r, C) = Shft(y)(x)
      Next C
   Next r
   Range("D17").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
   End If

End Sub

so that the result resembles the following
alternative.JPG
 
Last edited:
Upvote 0
How about
VBA Code: 
Sub Rows17_19()
   Dim Ary As Variant, Shft 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
   
   For r = 1 To UBound(Ary) - 1
      Itm = Not Itm
      For c = 1 To UBound(Ary, 2)
         Select Case c Mod 7
            Case 1 To 5
               Ary(r, c) = Shft(-Itm)
            Case 0
               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
Fluff said:
How about
VBA Code: 
Sub Rows17_19()
   Dim Ary As Variant, Shft 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
  
   For r = 1 To UBound(Ary) - 1
      Itm = Not Itm
      For c = 1 To UBound(Ary, 2)
         Select Case c Mod 7
            Case 1 To 5
               Ary(r, c) = Shft(-Itm)
            Case 0
               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
Click to expand...

Almost, but when i change a month it is static
I am trying to go with the week,
at the top of the table, in my mind, was trying to see when the week changed and hence change the letter.

alternative.JPG




so what it should look like is

alternative2.JPG
 
Upvote 0
Ok 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
   
   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
You must log in or register to reply here.

Similar threads

W
  • Question
VBA InputBox without entry quitting Sub/Macro
Replies
1
Views
111
Micron
M
SanjayGMusafir
  • Solved
VBA to add new record - Declaring variable
2
Replies
14
Views
146
Micron
M
S
  • Question
VBA Duplicates
Replies
1
Views
201
Alex Blakenburg
A
G
  • Question
Converting and copying specific data
Replies
1
Views
141
GerrardSVK
G
F
  • Question
How to get optionbutton values from two different groups
Replies
2
Views
242
NoSparks
N

Forum statistics

Threads
1,214,897
Messages
6,122,141
Members
449,066
Latest member
Andyg666

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