help with VBA & IF Statement

[bloodmilksky]

hi Guys,

I am currently using the below code for a holiday request form it takes the values on sheet 1:

Employee Name : B7
Employee Number : B9
Team : B11

matches them against a reference on their team holiday sheet (determined on sheet1 B11) To Book Holiday in on dates determined in :

Sheet 1 From(b21) To(C21) Half Or Full Day (D21)

What I am having trouble with is the booking of the holidays as at most I can only have 2 people off at a time but it is letting more than that and is also letting them exceed their allotted holiday which is determined in the request form (25days Sheet 1 B12)

would anyone know to put in a statement so if there is already 2 people off it would reply with a error message and the same for if they exceeded their holiday limit ( Sheet1 B12)

any questions I am more than happy to answer

many thanks

jamie

[B]Sub NewBookingCheck()[/B]
[B]Dim Name As String, Team As String, StartRng As String, EndRng As String, ShiftRng As String, Final As String[/B]
[B]Dim LastRow As Long[/B]
[B]Dim Rng As Range, Rng2 As Range, cRange As Range, Cell As Range[/B]
 
[B]Team = Sheets(“Sheet1”).Range("B11").Value[/B]
[B]Name = Team & Replace(Sheets(“Sheet1”).Range("B7").Value, " ", "")[/B]
[B]LastRow = Sheets(Team).Cells(Rows.Count, "A").End(xlUp).Row[/B]
 
[B]If Sheets(“Sheet1”).Range("B21").Value = Sheets(“Sheet1”).Range("C21").Value Then[/B]
   
[B]    StartRng = Left(Sheets(“Sheet1”).Range("B21").Value, 2) & Mid(Sheets(“Sheet1”).Range("B21").Value, 4, 2) & Right(Sheets(“Sheet1”).Range("B21").Value, 2)[/B]
[B]    If Sheets(“Sheet1”).Range("D21").Value <> "" Then[/B]
[B]        ShiftRng = Sheets(“Sheet1”).Range("D21").Value[/B]
[B]    Else[/B]
[B]        ShiftRng = "Full"[/B]
[B]    End If[/B]
[B]    Final = Team & StartRng & ShiftRng[/B]
[B]    Set Rng = Intersect(Sheets(Team).Range(Name), Sheets(Team).Range(Final))[/B]
   
[B]    If Application.WorksheetFunction.CountA(Sheets(Team).Range(Sheets(Team).Cells(3, Rng.Column), Sheets(Team).Cells(LastRow, Rng.Column))) < 2 Then[/B]
[B]        Rng.Interior.ColorIndex = 6[/B]
[B]        Rng.Value = "BOOKED"[/B]
[B]        Rng.Font.Bold = True[/B]
[B]    End If[/B]
   
[B]Else[/B]
   
[B]    StartRng = Left(Sheets(“Sheet1”).Range("B21").Value, 2) & Mid(Sheets(“Sheet1”).Range("B21").Value, 4, 2) & Right(Sheets(“Sheet1”).Range("B21").Value, 2)[/B]
[B]    EndRng = Left(Sheets(“Sheet1”).Range("C21").Value, 2) & Mid(Sheets(“Sheet1”).Range("C21").Value, 4, 2) & Right(Sheets(“Sheet1”).Range("C21").Value, 2)[/B]
[B]    ShiftRng = "Full"[/B]
[B]    Final = Team & StartRng & ShiftRng[/B]
[B]    Set Rng = Intersect(Sheets(Team).Range(Name), Sheets(Team).Range(Final))[/B]
[B]    Final = Team & EndRng & ShiftRng[/B]
[B]    Set Rng2 = Intersect(Sheets(Team).Range(Name), Sheets(Team).Range(Final))[/B]
[B]    Set cRange = Sheets(Team).Range(Rng, Rng2)[/B]
 
[B]    For Each Cell In cRange[/B]
[B]        If Application.WorksheetFunction.CountA(Sheets(Team).Range(Sheets(Team).Cells(3, Cell.Column), Sheets(Team).Cells(LastRow, Cell.Column))) < 2 Then[/B]
[B]            Cell.Interior.ColorIndex = 6[/B]
[B]            Cell.Value = "BOOKED"[/B]
[B]            Cell.Font.Bold = True[/B]
[B]        End If[/B]
[B]    Next Cell[/B]
   
[B]End If[/B]
 
[B]MsgBox "Complete"[/B]
 
[B]Run "HaveYouFinished"[/B]
 
[B]End Sub[/B]

 

[Rhodie72]

Have look at this lot. It may help you decipher the problem source after condensing the code to more easily understood code.
When using arrays (and anything digital!) counting starts from 0 (not 1). you can use "Option Base #" to set it to count from 0 or 1 outside your sub routine.

Option Explicit

Sub NewBookingCheck()
'help with VBA & IF Statement

'   hi Guys, _
    I am currently using the below code for a holiday request form it takes the values on sheet 1:

'   Employee Name: B7 _
    Employee Number: B9 _
    Team:      B11

'   matches them against a reference on their team holiday sheet on Sheet1!(determined by "B11") _
    To Book Holiday in on dates determined in : _
    "Sheet1", sourced @ ("B21:C21") Half Or Full Day ("D21")

'   What I am having trouble with is the booking of the holidays as _
    at most I can only have 2 people off at a time but _
    it is letting more than that and _
    is also letting them exceed their allotted holiday which _
    is determined in the request form (25days Sheet 1 B12)

'   Would anyone know to put in a statement so if there is already 2 _
    people off it would reply with a error message and the same for if _
    they exceeded their holiday limit (Sheet1 B12) _
    jamie

Dim Name As String, Team As String, StartRng As String, _
    EndRng As String, ShiftRng As String, Final As String, _
    LastRow As Long, Rng As Range, Rng2 As Range, _
    cRange As Range, Cell As Range
' This switch tells how many people are off on a particular half-day _
    This can be either True or False for 2 people being off at the same time!
Dim NumPeopleOff As Boolean

'There is only 1 sheet in use, so we embrace all functions within it _
    Because we deprecated ActiveWorkbook.Sheets("Sheet1") we can _
    shorten notation throughout to:
With ActiveWorkbook.Sheets("Sheet1")

    ' Pick a team name. (Note: numbers might be better for boolean functions _
        and we can keep the teams' numbered in VBA comments)
    Team = .[B11].Value
    Name = Team & Replace(.[B7].Value, " ", "")
    LastRow = Sheets(Team).Cells(Rows.Count, "A").End(xlUp).Row
    ' "Final" declaration moved here saves on RAM overhead and code parsing time
    Final = Array(Team & StartRng & ShiftRng, Team & EndRng & ShiftRng)

' Due to lack of documentation we don't know what is happening from here on... _
    This is where NumPeopleOff is locically the last option _
    as it appears last after all other date selections have been made.
' // We use "Select Case" in stead of "If" for it's ease among _
    multip[le options from a single determinant.
' Primary test nest
    Select Case .[B21].Value = .[C21].Value
    Case True
        With .[B21]
            StartRng = Left(.Value, 2) & Mid(.Value, 4, 2) & Right(.Value, 2)
        End With
        ' If you want to correct below then just remove the "_". _
        If you want it in there then maybe it should be outside "Primary test nest"
        'With .[C21] ' Missing this section. Is it required? _
            EndRng = Left(.Value, 2) & Mid(.Value, 4, 2) & Right(.Value, 2) ' _
        End With

            Select Case .[D21].Value
                Case Not Empty: ShiftRng = .[D21].Value
                Case Else: ShiftRng = "Full"
            End Select

        With Sheets(Team)
            Set Rng = Intersect(.Range(Name), .Range(Final(0))) 'Changed Final to an array
' I suspect this is where the issue of double booking is coming from...
            Select Case WorksheetFunction.CountA(.Range(.Cells(3, Rng.Column), .Cells(LastRow, Rng.Column)))
            Case Is < 2
                With Rng
                    .Interior.Color = vbRed
                    .Value = "BOOKED"
                    .Font.Bold = True
                End With
            Case Is >= 2 ' Added this because it was missing!
                MsgBox "What if the answer is greater than(>) or = to 2?" & Chr(13) & _
                    "What do we want to do then?", vbQuestion = vbCancel, "Booking Time Off..."
                Exit Sub
            End If
        End With

    Case False ' There is no documentation as to what is being aimed at here onwards...
        With .[B21]
            StartRng = Left(.Value, 2) & Mid(.Value, 4, 2) & Right(.Value, 2)
        End With
        With .[C21]
            EndRng = Left(.Value, 2) & Mid(.Value, 4, 2) & Right(.Value, 2)
        End With

        ShiftRng = "Full"

        With Sheets(Team)
            Set Rng = Intersect(.Range(Name), .Range(Final(0)))
        End With

        Set Rng2 = Intersect(Sheets(Team).Range(Name), Sheets(Team).Range(Final(1)))
        Set cRange = Sheets(Team).Range(Rng, Rng2)

        For Each Cell In cRange
            If Application.WorksheetFunction.CountA(Sheets(Team).Range(Sheets(Team).Cells(3, Cell.Column), Sheets(Team).Cells(LastRow, Cell.Column))) < 2 Then
                With Cell
                    .Interior.Color = vbRed
                    .Value = "BOOKED"
                    .Font.Bold = True
                End With
            End If
        Next Cell

    End Select
End With
    MsgBox "Complete"

    Run "HaveYouFinished"

End Sub