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

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Hi & welcome to MrExcel.
Your file is asking me to sign to sign in. Can you please mark it for sharing & then post the link you get.
 
Upvote 0
Ok, thanks for that.
How about
VBA Code:
Sub ssm()
   Dim Ary As Variant, Shft As Variant
   Dim r As Long, c As Long, x As Long, y As Long
   
   Shft = Array(Array("P", "", "N", "", "M"), _
                Array("", "M", "P", "", "N"), _
                Array("N", "", "M", "P", ""), _
                Array("M", "P", "", "N", ""), _
                Array("", "N", "", "M", "P"))
                
   r = Range("B6").End(xlDown).Row
   c = Range("D5").End(xlToRight).Column
   Ary = Range("D6", Cells(r, c)).Value
   
   For r = 1 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         x = Int((c - 1) / 2) Mod 5
         y = (r - 1) Mod 5
         Ary(r, c) = Shft(y)(x)
      Next c
   Next r
   Range("D6").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
End Sub
 
Upvote 0
yes, looks more like it.
Did not know this method...need to learn how it works to understand it lol..
how would the formula be modified if I need two rows to be the same. So the first two rows have array 1 the 3rd and 4th row has the second array and so on..?
 
Upvote 0
It would be like
VBA Code:
         y = Int((r - 1) / 2) Mod 5
 
Upvote 0
been trying the solution changing the values after mod as it writes the first two rows correctly but the rest is not doing what it has been told lol...
 
Upvote 0
In what way? I get

ssm84.xlsm
BDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAH
6NOME1PPNNMMPPNNMMPPNNMM
7NOME2PPNNMMPPNNMMPPNNMM
8NOME3MMPPNNMMPPNNMMPPNN
9NOME4MMPPNNMMPPNNMMPPNN
10NOME5NNMMPPNNMMPPNNMMPP
11NOME6NNMMPPNNMMPPNNMMPP
12NOME7MMPPNNMMPPNNMMPPNN
13NOME8MMPPNNMMPPNNMMPPNN
14NOME9NNMMPPNNMMPPNNMMPP
15NOME10NNMMPPNNMMPPNNMMPP
Turni
 
Upvote 0
i am using
VBA Code:
Sub ssm()
   Dim Ary As Variant, Shft As Variant
   Dim r As Long, c As Long, x As Long, y As Long
   
   Shft = Array(Array("P", "", "N", "", "M"), _
                Array("", "M", "P", "", "N"), _
                Array("N", "", "M", "P", ""), _
                Array("M", "P", "", "N", ""), _
                Array("", "N", "", "M", "P"))
                
   r = Range("B6").End(xlDown).Row
   c = Range("D5").End(xlToRight).Column
   Ary = Range("D6", Cells(r, c)).Value
   
   For r = 1 To UBound(Ary)
      For c = 1 To UBound(Ary, 2)
         x = Int((c - 1) / 2) Mod 5
         y = ((r - 1) / 2) Mod 5
         Ary(r, c) = Shft(y)(x)
      Next c
   Next r
   Range("D6").Resize(UBound(Ary), UBound(Ary, 2)).Value = Ary
End Sub

and I get
1592313272952.png
 
Upvote 0
You missed the Int function.
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,217
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