Personnel Roster using Macro's

W

womeclr

New Member
Joined
Jul 13, 2015
Messages
5
Hi All,

Have a Volunteer Members Roster spreadsheet that is maintained by several people on a communal SharePoint.
Been manually creating a ERT 7 Day Forecast for years. Time consuming and fraught with error.
Created a series of Macro's to search the Roster and populate the Forecast.

Errors I'm getting is the people are scattered when they appear on Forecast due to the logical way VBA is run.
See Poor Layout vs Correct Layout.

Correct/ Better Layout
Correct Layout.jpg


Poorer Layout
Poor Layout.jpg


VBA's below Minisheet



Mr Excel Test.xlsm
ABCDEFGHIJKLMNOPQRSTUV
1QUALIFIED DAYSHIFT6647333333633346684
2TRAINEES DAYSHIFT3332000001333334442
3
4QUALIFIED NIGHTSHIFT0112222222222221111
5TRAINEES NIGHTSHIFT1222222211111111100
6
7Volunteer MembersJan-24
8MonTueWedThuFriSatSunMonTueWedThuFriSatSunMonTueWedThuFri
9RosterNameStatus1-Jan2-Jan3-Jan4-Jan5-Jan6-Jan7-Jan8-Jan9-Jan10-Jan11-Jan12-Jan13-Jan14-Jan15-Jan16-Jan17-Jan18-Jan19-Jan
10Panel APerson ACaptainDDDDRRRRRRDDDDDDDDR
11Panel APerson BTrainedOOOORRRRRROOOOOOOOR
12Panel APerson CMedicRRRDDDDDDDDRRRRRRNN
13Panel APerson DLv1 OnlyDDDDRRRRRRDDDDDDDDR
14Panel APerson ERecruitDDDRRRRRRDDDDDDDDRR
15Panel APerson FTrainedDDDDRRRRRRDDDDDDDDR
16Panel APerson GTrainedALALALALRRRRRRALALALALDDDDR
17Panel APerson HTrainedDDDDRRRRRRDDDDDDDDR
18Panel BPerson JCaptainRRRDDDDDDDDRRRRRRDD
19Panel BPerson LTrainedRRRDDDDDDDDRRRRTRTRTRTR
20Team 2Person 2RecruitNNNRRRRRRRDDDDDDDDR
21Team 3Person 3TrainedRRRNNNNNNNRRRRRRRDD
22Team 3Person 5TrainedRNNNNNNNRRRRRRRDDDD
23Team 3Person 6TrainedRALALALALALALALRRRRRRRDDDD
24Team 3Person 7Lv1 OnlyRRRNNNNNNNRRRRRRRDD
25Team 3Person 8RecruitRNNNNNNNRRRRRRRDDDD
26Team 4Person 11TrainedDDRRRRRRALALALALALALALRRRR
27Team 4Person 12TrainedDDRRRRRRNNNNNNNRRRR
28Team 4Person 13TrainedDDDDRRRRRRNNNNNNNRR
29Team 4Person 14Lv1 OnlyDDDDRRRRRRNNNNNNNRR
30
31LEGEND
32DAYSD
33NIGHTSN
34RNRR
35ANNUAL LEAVEAL
36TRAININGTR
37SICK LEAVESL
38OFF SITE / SECONDMENTSO
39
40Captain
41Medic
42Trained
43Lv1 Only
44Recruit
45
2024
Cell Formulas
RangeFormula
D1:V1D1=COUNTIFS(D$10:D$41,"D",$C$10:$C$41,"Captain")+COUNTIFS(D$10:D$41,"D",$C$10:$C$41,"Medic")+COUNTIFS(D$10:D$41,"D",$C$10:$C$41,"Trained")
D2:V2D2=COUNTIFS(D$10:D$41,"D",$C$10:$C$41,"Lv1 Only")+COUNTIFS(D$10:D$41,"D",$C$10:$C$41,"Recruit")
D4:V4D4=COUNTIFS(D$10:D$41,"N",$C$10:$C$41,"Captain")+COUNTIFS(D$10:D$41,"N",$C$10:$C$41,"Medic")+COUNTIFS(D$10:D$41,"N",$C$10:$C$41,"Trained")
D5:V5D5=COUNTIFS(D$10:D$41,"N",$C$10:$C$41,"Lv1 Only")+COUNTIFS(D$10:D$41,"N",$C$10:$C$41,"Recruit")
D8:V8D8=WEEKDAY(D9)
Cells with Conditional Formatting
CellConditionCell FormatStop If True
C3:C4,D1:V5Cellcontains a blank value textYES
C3:C4,D1:V5Cell Valuebetween 5 and 50textNO
C3:C4,D1:V5Cell Valuebetween 3 and 4textNO
C3:C4,D1:V5Cell Value<=3textNO
C6,D7:D8,E8:V8,C9:C1048576Cell Value="Captain"textNO
C6,D7:D8,E8:V8,C9:C1048576Cell Value="Medic"textNO
C6,D7:D8,E8:V8,C9:C1048576Cell Value="Trained"textNO
C6,D7:D8,E8:V8,C9:C1048576Cell Value="Lv1 Only"textNO
C6,D7:D8,E8:V8,C9:C1048576Cell Value="Recruit"textNO
9:9Dates OccurringtodaytextNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="TR"textNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="R"textNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="O"textNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="AL"textNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="SL"textNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="N"textNO
A6:V6,A7,A3:B4,A1:A2,A4:A5,A32:V41,A31,C31:V31,D7:V8,A9:V30Cell Value="D"textNO
B32:B41,B10:B30Expression=$C10="Captain"textNO
B32:B41,B10:B30Expression=$C10="Medic"textNO
B32:B41,B10:B30Expression=$C10="Trained"textNO
B32:B41,B10:B30Expression=$C10="Lv1 Only"textNO
B32:B41,B10:B30Expression=$C10="Recruit"textNO
Cells with Data Validation
CellAllowCriteria
C10:C29List=$A$40:$A$45
D10:V29ListD, N, AL, SL, TR, O, R



VBA's
VBA Code: 
Sub refresh_ERT7DayForecast()

UnhideRows
ResetPage
Clear_DS
Clear_NS
FullERT_DS
TraineeERT_DS
FullERT_NS
TraineeERT_NS
HideEmptyRows
Range("C2").Select

End Sub

Sub FullERT_DS()

'get user define start date from worksheet "ERT 7 Day Forecast"
StartDate = Sheets("ERT 7 Day Forecast").Range("C2").Value

'find date start col from worksheet "2024"
Startcol = 4
readrow = 9
readCol = Startcol

Do While Sheets("2024").Cells(readrow, readCol).Value <> StartDate
   
    readCol = readCol + 1

Loop

Startcol = readCol

'Loop for 7 days

writecol = 2
Do While writecol < 9
writerow = 15
    'Loop down for Captain
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Captain" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "D" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Captain"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
   
    'Loop down for Medic "Cert 4 qualified"
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Medic" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "D" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Medic"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
       
    'Loop down for Trained
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Trained" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "D" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Trained"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
readCol = readCol + 1
writecol = writecol + 1

Loop

End Sub

Sub TraineeERT_DS()

'get user define start date from worksheet "ERT 7 Day Forecast"
StartDate = Sheets("ERT 7 Day Forecast").Range("C2").Value

'find date start col from worksheet "2024"
Startcol = 4
readrow = 9
readCol = Startcol

Do While Sheets("2024").Cells(readrow, readCol).Value <> StartDate
   
    readCol = readCol + 1

Loop

Startcol = readCol

'Loop for 7 days

writecol = 2
Do While writecol < 9
writerow = 30
   'Loop down for Lv1 Only
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Lv1 Only" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "D" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Level 1"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
    'Loop down for Recruit
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Recruit" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "D" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Trainee"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop

readCol = readCol + 1
writecol = writecol + 1

Loop

End Sub


Sub FullERT_NS()

Clear_NS

'get user define start date from worksheet "2024"
StartDate = Sheets("ERT 7 Day Forecast").Range("C2").Value

'find date start col from worksheet "2024"
Startcol = 4
readrow = 9
readCol = Startcol

Do While Sheets("2024").Cells(readrow, readCol).Value <> StartDate
   
    readCol = readCol + 1

Loop

Startcol = readCol

'Loop for 7 days

writecol = 11
Do While writecol < 18
writerow = 15
    'Loop down for Captain
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Captain" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "N" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Captain"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
   
    'Loop down for Medic "Cert 4 qualified"
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Medic" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "N" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Medic"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
       
    'Loop down for Trained
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Trained" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "N" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Trained"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop

readCol = readCol + 1
writecol = writecol + 1

Loop


End Sub

Sub TraineeERT_NS()

'get user define start date from worksheet "2024"
StartDate = Sheets("ERT 7 Day Forecast").Range("C2").Value

'find date start col from worksheet "2024"
Startcol = 4
readrow = 9
readCol = Startcol

Do While Sheets("2024").Cells(readrow, readCol).Value <> StartDate
   
    readCol = readCol + 1

Loop

Startcol = readCol

'Loop for 7 days

writecol = 11
Do While writecol < 18
writerow = 30
'Loop down for Lv1 Only
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Lv1 Only" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "N" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Level 1"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop
    'Loop down for Recruit
        readrow = 10
        Do While Sheets("2024").Cells(readrow, 3).Value <> ""
            If Sheets("2024").Cells(readrow, 3).Value = "Recruit" Then
               
                If Sheets("2024").Cells(readrow, readCol).Value = "N" Then
                   
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Value = Sheets("2024").Cells(readrow, 2).Value
                    Sheets("ERT 7 Day Forecast").Cells(writerow, writecol).Style = "Trainee"
                    writerow = writerow + 1
                End If
               
            End If
       
        readrow = readrow + 1
        Loop

readCol = readCol + 1
writecol = writecol + 1

Loop

End Sub


Sub Clear_DS()

    Sheets("ERT 7 Day Forecast").Select
    Range("B15:H44").Select
    Selection.ClearContents
    Selection.Style = "Normal"
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
        With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
        With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

End Sub

Sub Clear_NS()

    Sheets("ERT 7 Day Forecast").Select
    Range("K15:Q44").Select
    Selection.ClearContents
    Selection.Style = "Normal"
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
        With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
        With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

End Sub

Sub HideEmptyRows()

Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.rows("15:44")
rows = r.rows.Count

For i = rows To 1 Step (-1)

If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Hidden = True
Next
End Sub

Sub UnhideRows()

    rows("15:50").Select
        Selection.EntireRow.Hidden = False
    Range("C2").Select
End Sub

Sub ResetPage()

    Sheets("MASTER").Select
    rows("9:60").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("ERT 7 Day Forecast").Select
    rows("9").Select
    ActiveSheet.Paste
    Range("C2").Select
End Sub
 
Last edited by a moderator:

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
You must log in or register to reply here.

Similar threads

L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
336
RoryA
RoryA
D
  • Question
Problems Encountered When Generating VBA Excel Charts with 15-Minute Interval Data.
Replies
0
Views
160
dilshod_k
D
john Smith72
  • Solved
Auto filter VBA
Replies
2
Views
121
john Smith72
john Smith72
S
  • Question
Need code that adds multiple new rows to table to include a check box in column "L" for each new row
Replies
0
Views
340
sspatriots
S
MrDB4Excel
  • Solved
DuckDuckGo Conditional Format
2
Replies
12
Views
290
MrDB4Excel
MrDB4Excel

Forum statistics

Threads
1,215,073
Messages
6,122,977
Members
449,095
Latest member
Mr Hughes

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