• 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

  • BOOK.xlsm
    86.4 KB · Views: 30
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