• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Calendar based holiday booking excel

K

KARTINA AZMAN

New Member
Hi.. I need help. I am trying to make an excel file which employee can plan their holiday without overlapping with each others'.
I am now stuck with the "finding date" part. There is a code from ozgrid but I cannot make it work regardless of how I changed the date format.

This is how far I have manage. Kindly help. Thank you.

Code: 
Private Sub CommandButton2_Click()
Dim i As Long
Dim strdate As String
Dim rCell As Range
Dim IReply As Long
Dim ws As Worksheet



strdate = Me.tbDtF.Value
    'Cancelled
    If strdate = "False" Then Exit Sub
    strdate = Format(strdate, "Short Date")

    On Error Resume Next

For Each ws In ThisWorkbook.Worksheets
    If ws.Name = "LIST" Then Exit Sub     'to look for date in calendar sheets only
    If ws.Name <> "LIST" Then
        Set rCell = Cells.Find(What:=CDate(strdate), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    End If
    If Not rCell Is Nothing Then
        'MsgBox "Found at " & rngX.Address
        If rCell.Offset(1, 0).Value < 6 Then   'limit for ppl on leave per day is 5
            With ThisWorkbook.Worksheets("LIST") 'sending userform entry into worksheet "list"
                i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                 .Cells(i, 1).Value = Me.tbUser.Value
                 .Cells(i, 2).Value = Me.tbDtF.Value
                 .Cells(i, 3).Value = Me.tbDtT.Value
                 .Cells(i, 5).Value = Me.tbRemarks.Value
            End With
            rCell.Offset(1, 0).Value = rCell.Offset(1, 0).Value + 1  'adding value 1 to the cell below found date
            rCell.Offset(2, 0).Value = rCell.Offset(2, 0).Value + "," + Me.tbUser.Value 'adding the username to the cell
         Else: MsgBox "Sorry, maximum people have applied for leave on that date"
         End If
    End If
    On Error GoTo 0
    If rCell Is Nothing Then
        lReply = MsgBox("Date cannot be found. Try Again", vbYesNo)
        If lReply = vbYes Then UserForm1.tbDtF.SetFocus
        If lReply = vbNo Then UserForm1.Hide
       
       
    End If
Next ws

MsgBox "Your leave booking is submitted"

End Sub

Username:admin
password: admin
 

Attachments

First thing, you shouldn't loop through each sheet. Instead use strdate to search in specific workbook.

Something like... (tested for May 12, 2017 and worked on my end).
Code: 
Private Sub CommandButton2_Click()
Dim i As Long
Dim strdate As String
Dim rCell As Range
Dim IReply As Long
Dim ws As Worksheet



strdate = Me.tbDtF.Value
    'Cancelled
    If strdate = "False" Then Exit Sub
    strdate = Format(strdate, "Short Date")

    On Error Resume Next


'    If ws.Name = "LIST" Then Exit Sub    'to look for date in calendar sheets only
    Set rCell = Worksheets(UCase(Format(strdate, "mmm"))).Cells.Find(What:=CDate(strdate), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
    If Not rCell Is Nothing Then
        'MsgBox "Found at " & rngX.Address
        If rCell.Offset(1, 0).Value < 6 Then  'limit for ppl on leave per day is 5
            With ThisWorkbook.Worksheets("LIST") 'sending userform entry into worksheet "list"
                i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
                .Cells(i, 1).Value = Me.tbUser.Value
                .Cells(i, 2).Value = Me.tbDtF.Value
                .Cells(i, 3).Value = Me.tbDtT.Value
                .Cells(i, 5).Value = Me.tbRemarks.Value
            End With
            rCell.Offset(1, 0).Value = rCell.Offset(1, 0).Value + 1  'adding value 1 to the cell below found date
            rCell.Offset(2, 0).Value = rCell.Offset(2, 0).Value + "," + Me.tbUser.Value 'adding the username to the cell
        Else: MsgBox "Sorry, maximum people have applied for leave on that date"
        End If
    End If
    On Error GoTo 0
    If rCell Is Nothing Then
        lReply = MsgBox("Date cannot be found. Try Again", vbYesNo)
        If lReply = vbYes Then UserForm1.tbDtF.SetFocus
        If lReply = vbNo Then UserForm1.Hide
    End If


MsgBox "Your leave booking is submitted"

End Sub
 
Hi.. when I try to apply this to real situation, some problem arised:
1) How to address the situation where the application is more than one day (current macro just find the date of the start date)?
- I tried to amend from your version but when I debug the error would be "For without Next"
- so I tried to put "Next i" at line 71 but then the error come out as "Next without for block" :(

2)I would like to lock have All Calendar Sheets (JAN-DEC) . Read something about locking and unlock using vba but nothing happened in my trial :(

Below is what i manage to scrap together

I really appreciate any points to learn and help.

Thank You very much

Code: 
Private Sub CommandButton2_Click()
Dim i As Long
Dim strdate, enddate, rngedate As Date
Dim rCell As Range
Dim IReply As Long
Dim ws As Worksheet
Dim d As Date
Dim x As Integer
Dim OutRng As Range
Dim lastrow As Long

strdate = Me.tbDtF.Value
enddate = Me.tbDtT.Value
If strdate = "False" Then Exit Sub  'Cancelled
  strdate = Format(strdate, "Short Date")
On Error Resume Next
If enddate - strdate <> 0 Then 'generate list of date base on entry to buffer worksheet
  ws = ThisWorkbook.Worksheets("Buffer")
  With ws
  lastrow = .Cells(.Rows.Count, 1).endxlup.Row
  End With
  ws.Range("A1").Value = strdate
  ws.Range("B1").Value = enddate
  Set OutRng = OutRng.Range("A1")

  ColIndex = 0
  For i = strdate To enddate
  OutRng.Offset(ColIndex, 0) = i
  ColIndex = ColIndex + 1
  Next

  'looping all date to find
  For i = 1 To lastrow
  rngedate = Range("A" & i).Value
  ' If ws.Name = "LIST" Then Exit Sub  'to look for date in calendar sheets only
  Set rCell = Worksheets(UCase(Format(strdate, "mmm"))).Cells.Find(What:=CDate(rngedate), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
  If Not rCell Is Nothing Then
  rCell.Offset(1, 0).Value = rCell.Offset(1, 0).Value + 1  'adding value 1 to the cell below found date
  rCell.Offset(2, 0).Value = rCell.Offset(2, 0).Value + " " + Me.tbUser.Value 'adding the username to the cell

  If rCell.Offset(1, 0).Value < 6 Then  'limit for ppl on leave per day is 5
  With ThisWorkbook.Worksheets("LIST") 'sending userform entry into worksheet "list"
  i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
  .Cells(i, 1).Value = Me.tbUser.Value
  .Cells(i, 2).Value = Me.tbDtF.Value
  .Cells(i, 3).Value = Me.tbDtT.Value
  .Cells(i, 5).Value = Me.tbRemarks.Value
  End With

  MsgBox "Your leave booking is submitted"
  Else: MsgBox "Sorry, maximum people have applied for leave on" & rCell & "that date"
  End If


  End If
If enddate - strdate = 0 Then
  Set rCell = Worksheets(UCase(Format(strdate, "mmm"))).Cells.Find(What:=CDate(rngedate), After:=Range("A1"), LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
  If Not rCell Is Nothing Then
  'MsgBox "Found at " & rngX.Address
  If rCell.Offset(1, 0).Value < 6 Then  'limit for ppl on leave per day is 5
  With ThisWorkbook.Worksheets("LIST") 'sending userform entry into worksheet "list"
  i = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
  .Cells(i, 1).Value = Me.tbUser.Value
  .Cells(i, 2).Value = Me.tbDtF.Value
  .Cells(i, 3).Value = Me.tbDtT.Value
  .Cells(i, 5).Value = Me.tbRemarks.Value
  End With
  rCell.Offset(1, 0).Value = rCell.Offset(1, 0).Value + 1  'adding value 1 to the cell below found date
  rCell.Offset(2, 0).Value = rCell.Offset(2, 0).Value + " " + Me.tbUser.Value 'adding the username to the cell
  MsgBox "Your leave booking is submitted"
  Else: MsgBox "Sorry, maximum people have applied for leave on" & rCell & "that date"
  End If
  End If
End If
  On Error GoTo 0
  If rCell Is Nothing Then
  lReply = MsgBox("Date cannot be found. Try Again", vbYesNo)
  If lReply = vbYes Then UserForm1.tbDtF.SetFocus
  If lReply = vbNo Then UserForm1.Hide
  End If

End Sub


▬▬▬▬▬▬▬▬▬ Mod edit : thread moved to appropriate forum !
​
 
You must log in or register to reply here.
Back
Top