Moving Firemen around

[markstoehr]

I have a daily staffing sheet that I'm trying to move firemen from one truck to another. It shows how many firemen are on a truck on a given day. Currently, I have to manually type the name of the Firefighter when moving. I want to try to make this automatic.

The sheet is divided into Trucks and in each truck, there are 4 columns representing 6-hour shifts in the 24hours that we work. On each truck, there are the permanent Firemen. But sometimes if someone is sick for example Firemen need to move to another truck.

I want to put the number of the hall beside the fireman's name (shown in red) and have them automatically show up on the indicated truck in the gray area (shown in blue). This would require some VBA. Firemen can be moved to any truck. I would have a drop menu beside each name so as not to have an error on entry. S = Sick

An example of a move would be D Rowntree that works on Truck R426 needs to move to Truck R423 for the 4 time periods. I enter R423 beside his name and he is automatically added in the gray area under R423 and then added to the total on the truck.

Any help on the VBA part would greatly be appreciated. I normally do coding in PHP and am lagging behind here.

Thanks in advance

​

 

[Peter_SSs]

OK, after re-think.

1. Back to a single sheet in whatever grid layout you want, provided all blocks are equal size and start in row 1. Note that I still have hidden columns E and O. Suggest same setup at least until concept is proven.
2. Select all the yellow cells (they don't need to actually be yellow in your sheet) and name that range 'Entry'.
3. Select all the grey cells and name that range 'Temp'.
4. Note new formulas in F1 and P1 each copied across and then those sections copied down to the other header counting cells.

Excel Workbook
	A	B	C	D	F	G	H	I	J	K	L	M	N	P	Q	R	S
1	5	4		R423	5	5	5	5		5	4		R426	5	5	5	5
2	E1	ADC	M	Cannon						E11	CAPT	G	Faulker
3	E2	AC	C	Zanussi						E12	AC	J	Vanusio
4	E3	FF	G	Vandeheuvel						E13	FF	N.	Macelli
5	E4	FF	M	Seguin						E14	FF	V.	Wajda
6	E5	FF	P	Doherty						E15	FF	D	Rowntree
7
8
9
10
11
12
13	5	3		Q423	5	5	5	5		5	4		P426	5	5	5	5
14	E6	CAPT	F	Ennis						E16	CAPT	J.	Fievez
15	E7	AC	D.	Bradshaw						E17	AC	J.	Bredin
16	E8	FF	J.	Pennock						E18	FF	S.	Regier
17	E9	FF	C.	Koinis						E19	FF	M.	Riley
18	E10	FF	E	Dawson						E20	FF	P.	Drozd
19
20
21
22
23
24
Sheet5

5. Right-click the sheet name tab -> View Code -> Paste this code

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Moves As Range, c As Range, rToTruck As Range
  Dim cRow As Long, cCol As Long, NewRow As Long
  Dim FromTruck As String, ToTruck As String
  
  Const BlockRows As Long = 12  '<- Rows in each truck block
  Const BlockCols As Long = 10  '<- Cols in each block, incl. hidden col & blank col between blocks
  Const PermRows As Long = 7    '<- Rows in each block before the grey section
  Const TruckNames As String = "|R423|R426|Q423|P426|"  '<- Add more as required
  
  If Not Intersect(Target, Range("Entry")) Is Nothing Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Range("Temp").ClearContents
    On Error Resume Next
    Set Moves = Range("Entry").SpecialCells(xlConstants)
    On Error GoTo 0
    If Not Moves Is Nothing Then
      For Each c In Moves
        ToTruck = c.Value
        If InStr(1, TruckNames, "|" & ToTruck & "|") > 0 Then
          cRow = c.Row Mod BlockRows
          cCol = c.Column Mod (BlockCols)
          FromTruck = Cells(c.Row - cRow + 1, c.Column - cCol + 4).Value
          Set rToTruck = ActiveSheet.UsedRange.Find(What:=ToTruck, After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
          Do Until rToTruck.Row Mod BlockRows = 1
            Set rToTruck = ActiveSheet.UsedRange.FindNext(After:=rToTruck)
          Loop
          NewRow = 0
          On Error Resume Next
          NewRow = rToTruck.Offset(, -3).Resize(BlockRows).Find(What:=c.Offset(, -cCol + 1).Value, LookIn:=xlValues, LookAt:=xlWhole).Row
          On Error GoTo 0
          If NewRow = 0 Then
            NewRow = rToTruck.Offset(BlockRows, -3).End(xlUp).Row + 1
            If NewRow < rToTruck.Row + PermRows Then NewRow = rToTruck.Row + PermRows
          End If
          Cells(NewRow, rToTruck.Column - 3).Resize(, 4).Value = c.Offset(, -cCol + 1).Resize(, 4).Value
          Cells(NewRow, rToTruck.Column - 4 + cCol).Value = FromTruck
        End If
      Next c
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  End If
End Sub

Here's my sheet after entering the red data.

Excel Workbook
	A	B	C	D	F	G	H	I	J	K	L	M	N	P	Q	R	S
1	5	4		R423	4	3	4	4		5	4		R426	4	4	4	4
2	E1	ADC	M	Cannon	S	S	S	S		E11	CAPT	G	Faulker
3	E2	AC	C	Zanussi						E12	AC	J	Vanusio	S	S	S	S
4	E3	FF	G	Vandeheuvel						E13	FF	N.	Macelli	S	S	S	S
5	E4	FF	M	Seguin						E14	FF	V.	Wajda
6	E5	FF	P	Doherty	R426	R426	R426	R426		E15	FF	D	Rowntree	Q423	Q423	Q423	Q423
7
8	E17	AC	J.	Bredin			P426	P426		E5	FF	P	Doherty	R423	R423	R423	R423
9	E19	FF	M.	Riley	P426					E10	FF	E	Dawson	Q423	Q423	Q423	Q423
10
11
12
13	5	3		Q423	3	3	3	3		5	4		P426	4	5	4	4
14	E6	CAPT	F	Ennis						E16	CAPT	J.	Fievez
15	E7	AC	D.	Bradshaw						E17	AC	J.	Bredin			R423	R423
16	E8	FF	J.	Pennock	S	S	S	S		E18	FF	S.	Regier
17	E9	FF	C.	Koinis	P426	P426	P426	P426		E19	FF	M.	Riley	R423
18	E10	FF	E	Dawson	R426	R426	R426	R426		E20	FF	P.	Drozd	S	S	S	S
19
20	E15	FF	D	Rowntree	R426	R426	R426	R426		E9	FF	C.	Koinis	Q423	Q423	Q423	Q423
21
22
23
24
Sheet5

 

[markstoehr]

Sorry about the delay in response. Life.

Thank you, this is excellent. Works as I need. I have added all the trucks.

One question if I want to start on a row other than 1 can I do that. I want to add a summary at the top of the "Off" codes. There are several I will just add them up from the entries.

THANK YOU VERY MUCH FOR ALL YOUR HELP.

 

[Peter_SSs]

One question if I want to start on a row other than 1 can I do that.

1. Remove or disable the code.
2. Insert your new rows at the top. For example, insert 2 rows so the first truck headers are at row 3.
3. Add your summary above the truck grids (something will need to be in row 1)
4. Replace the previous code with this code (changes highlighted)

So you can change the first row again later if you want by repeating the steps above and you would then only need to change the first 'Const' line in the code below.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Moves As Range, c As Range, rToTruck As Range
  Dim cRow As Long, cCol As Long, NewRow As Long
  Dim FromTruck As String, ToTruck As String
  
  Const FirstHdrRow As Long = 3 '<- Row with first truck headings
  Const BlockRows As Long = 12  '<- Rows in each truck block
  Const BlockCols As Long = 10  '<- Cols in each block, incl. hidden col & blank col between blocks
  Const PermRows As Long = 7    '<- Rows in each block before the grey section
  Const TruckNames As String = "|R423|R426|Q423|P426|"  '<- Add more as required
  
  If Not Intersect(Target, Range("Entry")) Is Nothing Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Range("Temp").ClearContents
    On Error Resume Next
    Set Moves = Range("Entry").SpecialCells(xlConstants)
    On Error GoTo 0
    If Not Moves Is Nothing Then
      For Each c In Moves
        ToTruck = c.Value
        If InStr(1, TruckNames, "|" & ToTruck & "|") > 0 Then
          cRow = c.Row Mod BlockRows
          cCol = c.Column Mod (BlockCols)
          FromTruck = Cells(c.Row - cRow + FirstHdrRow, c.Column - cCol + 4).Value
          Set rToTruck = ActiveSheet.UsedRange.Find(What:=ToTruck, After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
          Do Until rToTruck.Row Mod BlockRows = FirstHdrRow
            Set rToTruck = ActiveSheet.UsedRange.FindNext(After:=rToTruck)
          Loop
          NewRow = 0
          On Error Resume Next
          NewRow = rToTruck.Offset(, -3).Resize(BlockRows).Find(What:=c.Offset(, -cCol + 1).Value, LookIn:=xlValues, LookAt:=xlWhole).Row
          On Error GoTo 0
          If NewRow = 0 Then
            NewRow = rToTruck.Offset(BlockRows, -3).End(xlUp).Row + 1
            If NewRow < rToTruck.Row + PermRows Then NewRow = rToTruck.Row + PermRows
          End If
          Cells(NewRow, rToTruck.Column - 3).Resize(, 4).Value = c.Offset(, -cCol + 1).Resize(, 4).Value
          Cells(NewRow, rToTruck.Column - 4 + cCol).Value = FromTruck
        End If
      Next c
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  End If
End Sub

 

[markstoehr]

Great thank you

Another question if I enter in the gray area manually it is overwritten by the VBA. Can this code allow for manual additions? (if staff are not on the list of trucks. If staff are working from another part of the city or from another platoon for the day)

I have added to the VBA to allow for the ToTruck value to end with other letters for record keeping. EG R421AC (Acting Captain), C42ADC (Acting District Chief), C42APC (Acting Platoon Chief). The full including eg AC is not required in the Gray area.

Private Sub Worksheet_Change(ByVal Target As Range)  Dim Moves As Range, c As Range, rToTruck As Range
  Dim cRow As Long, cCol As Long, NewRow As Long
  Dim FromTruck As String, ToTruck As String
  
  Const FirstHdrRow As Long = 3 '<- Row with first truck headings
  Const BlockRows As Long = 12  '<- Rows in each truck block
  Const BlockCols As Long = 10  '<- Cols in each block, incl. hidden col & blank col between blocks
  Const PermRows As Long = 7    '<- Rows in each block before the grey section
  Const TruckNames As String = "|R421|Q421|AL421|P422|R423|Q423|C42|R425|P426|R426|Q426|"  '<- Add more as required
  
  If Not Intersect(Target, Range("Entry")) Is Nothing Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Range("Temp").ClearContents
    On Error Resume Next
    Set Moves = Range("Entry").SpecialCells(xlConstants)
    On Error GoTo 0
    If Not Moves Is Nothing Then
      For Each c In Moves
        ToTruck = c.Value
[COLOR=#0000ff]        If InStr(1, ToTruck, "AC") > 0 Then[/COLOR]
[COLOR=#0000ff]       ToTruck = Left(ToTruck, Len(ToTruck) - 2)[/COLOR]
[COLOR=#0000ff]        End If[/COLOR]
[COLOR=#0000ff]        If InStr(1, ToTruck, "ADC") > 0 Then[/COLOR]
[COLOR=#0000ff]       ToTruck = Left(ToTruck, Len(ToTruck) - 3)[/COLOR]
[COLOR=#0000ff]        End If[/COLOR]
[COLOR=#0000ff]        If InStr(1, ToTruck, "APC") > 0 Then[/COLOR]
[COLOR=#0000ff]       ToTruck = Left(ToTruck, Len(ToTruck) - 3)[/COLOR]
[COLOR=#0000ff]        End If[/COLOR]
        If InStr(1, TruckNames, "|" & ToTruck & "|") > 0 Then
          cRow = c.Row Mod BlockRows
          cCol = c.Column Mod (BlockCols)
          FromTruck = Cells(c.Row - cRow + FirstHdrRow, c.Column - cCol + 4).Value
          Set rToTruck = ActiveSheet.UsedRange.Find(What:=ToTruck, After:=Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
          Do Until rToTruck.Row Mod BlockRows = FirstHdrRow
            Set rToTruck = ActiveSheet.UsedRange.FindNext(After:=rToTruck)
          Loop
          NewRow = 0
          On Error Resume Next
          NewRow = rToTruck.Offset(, -3).Resize(BlockRows).Find(What:=c.Offset(, -cCol + 1).Value, LookIn:=xlValues, LookAt:=xlWhole).Row
          On Error GoTo 0
          If NewRow = 0 Then
            NewRow = rToTruck.Offset(BlockRows, -3).End(xlUp).Row + 1
            If NewRow < rToTruck.Row + PermRows Then NewRow = rToTruck.Row + PermRows
          End If
          Cells(NewRow, rToTruck.Column - 3).Resize(, 4).Value = c.Offset(, -cCol + 1).Resize(, 4).Value
          Cells(NewRow, rToTruck.Column - 4 + cCol).Value = FromTruck
        End If
      Next c
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  End If
End Sub

 

[Peter_SSs]

Another question if I enter in the gray area manually it is overwritten by the VBA. Can this code allow for manual additions? (if staff are not on the list of trucks. If staff are working from another part of the city or from another platoon for the day)

Not at all easily. Would this work-around suit you?

1. Leave the code exactly as you have it, though you may be safest to disable it (comment it all out or put Exit Sub temporarily right at the top of it) while the following steps are implemented.
2. Add another section as I have shown in U:AC. I used "OS" for "Outside" in cell X3 but you can use whatever you want.
3. The yellow range Z4:AC9 needs to be included in the 'Entry' named range. (You could edit that named range or it might be easier to just delete the named range and re-create it with the added range.)
4. If you don't want this extra section on your printed version, set the print area to A1:S26 or whatever range you have for the other trucks.
5. Re-enable the code and test.

Excel Workbook
	K	L	M	N	P	Q	R	S	T	U	V	W	X	Z	AA	AB	AC
1
2
3	5	4		R426	6	7	5	6					OS
4	E11	CAPT	G	Faulker						X1	AB	J	Bloggs		P426
5	E12	AC	J	Vanusio						X2	??	J	Doe	R426	R426		R426
6	E13	FF	N.	Macelli	P426
7	E14	FF	V.	Wajda
8	E15	FF	D	Rowntree
9
10	E9	FF	C.	Koinis		Q423
11	E18	FF	S.	Regier	P426
12	X2	??	J	Doe	OS	OS		OS
13
14
15	5	4		P426	4	5	3	4
16	E16	CAPT	J.	Fievez
17	E17	AC	J.	Bredin	S	S	S	S
18	E18	FF	S.	Regier	R426		R423	Q423
19	E19	FF	M.	Riley
20	E20	FF	P.	Drozd
21
22	E8	FF	J.	Pennock				Q423
23	E13	FF	N.	Macelli	R426
24	X1	AB	J	Bloggs		OS
25
26
Sheet5

 

[markstoehr]

Hello

That will work great. I had actually already done that. But thank you.

I do have a bit of a problem if I use the FirstHdrRow at 12 or more Excel crashes?

Thanks for all your input!!!

 

[Peter_SSs]

I do have a bit of a problem if I use the FirstHdrRow at 12 or more Excel crashes?

I hadn't imagined you moving the data down that much.
There are a couple of problems with my code in that circumstance. We will be able to solve it, but I can't put any time to it in the next 24 hours or so. Will be back after that.

 

[Peter_SSs]

See how this version goes.

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim Moves As Range, c As Range, rToTruck As Range
  Dim cRow As Long, cCol As Long, NewRow As Long, LastSearchCol As Long, SearchRows As Long, i As Long
  Dim FromTruck As String, ToTruck As String

  Const FirstHdrRow As Long = 15  '<- Row with first truck headings
  Const BlockRows As Long = 12    '<- Rows in each truck block
  Const BlockCols As Long = 10    '<- Cols in each block, incl. hidden col & blank col between blocks
  Const TruckNameCol As Long = 4  '<- Col in each block that contains the truck name header
  Const PermRows As Long = 7      '<- Rows in each block before the grey section
  Const TruckNames As String = "|R423|R426|Q423|P426|"  '<- Add more as required

  If Not Intersect(Target, Range("Entry")) Is Nothing Then
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Range("Temp").ClearContents
    On Error Resume Next
    Set Moves = Range("Entry").SpecialCells(xlConstants)
    On Error GoTo 0
    If Not Moves Is Nothing Then
      LastSearchCol = Cells(FirstHdrRow, Columns.Count).End(xlToLeft).Column
      SearchRows = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, SearchFormat:=False).Row - FirstHdrRow + 1
      For Each c In Moves
        ToTruck = c.Value
        If InStr(1, TruckNames, "|" & ToTruck & "|") > 0 Then
          cRow = (c.Row - FirstHdrRow + 1) Mod BlockRows
          cCol = c.Column Mod (BlockCols)
          FromTruck = Cells(c.Row - cRow + 1, c.Column - cCol + TruckNameCol).Value
          For i = TruckNameCol To LastSearchCol Step BlockCols
            Set rToTruck = Cells(FirstHdrRow, i).Resize(SearchRows).Find(What:=ToTruck, After:=Cells(FirstHdrRow, i), LookIn:=xlValues, LookAt:=xlWhole)
            If Not rToTruck Is Nothing Then Exit For
          Next i
          If rToTruck Is Nothing Then
            MsgBox "Truck " & ToTruck & " not found."
          Else
            NewRow = 0
            On Error Resume Next
            NewRow = rToTruck.Offset(, -3).Resize(BlockRows).Find(What:=c.Offset(, -cCol + 1).Value, LookIn:=xlValues, LookAt:=xlWhole).Row
            On Error GoTo 0
            If NewRow = 0 Then
              NewRow = rToTruck.Offset(BlockRows, -3).End(xlUp).Row + 1
              If NewRow < rToTruck.Row + PermRows Then NewRow = rToTruck.Row + PermRows
            End If
            Cells(NewRow, rToTruck.Column - 3).Resize(, 4).Value = c.Offset(, -cCol + 1).Resize(, 4).Value
            Cells(NewRow, rToTruck.Column - 4 + cCol).Value = FromTruck
          End If
        End If
      Next c
    End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
  End If
End Sub

 

[markstoehr]

Once again you have come up with excellent code.

THANK YOU THANK YOU THANK YOU

 

[Peter_SSs]

Once again you have come up with excellent code.

THANK YOU THANK YOU THANK YOU

Glad we seem to have covered all bases eventually.