I have a booking system that populates the names of guests in the form of a gantt style reservation chart.
Each date has two columns for same date. Currently if i book a person with arrival and departure date, it populates both columns.
I would like for the arrival to populate the second column of date, and the departure date to populate only the first column.
The idea is that a person can depart and another person booked on the same date in the same room.
Code for adding, edit lookup and delete for bookings are:
Each date has two columns for same date. Currently if i book a person with arrival and departure date, it populates both columns.
I would like for the arrival to populate the second column of date, and the departure date to populate only the first column.
The idea is that a person can depart and another person booked on the same date in the same room.
Code for adding, edit lookup and delete for bookings are:
VBA Code:
Sub AddMe()
'declare the variables
Dim Bws As Worksheet
Dim Fws As Worksheet
Dim Dt As Range
Dim Rm As Range
Dim ID As Range
Dim CK As Range
Dim orange As Range
Dim LastRow As Long
Dim nextrow As Range
'turn off screen updating
Application.ScreenUpdating = False
'variables
Set Bws = Sheet2
Set Fws = Sheet4
Set Dt = Bws.Range("V4")
Set Rm = Bws.Range("V3")
Set ID = Fws.Range("B5")
Set CK = Fws.Range("BM6")
On Error GoTo errHandler:
'check for sufficent data
If Bws.Range("V4").Value = "" Or Bws.Range("V3").Value = "" Or Bws.Range("An3").Value = "" Then
MsgBox "There is insufficient data to add"
Exit Sub
End If
'run the filter to check for duplicates
AdvChk
'if duplicate exist then stop and inform user
If CK.Value > 0 Then
MsgBox "This name or date already exists .This is a duplicate"
Exit Sub
End If
'find the next free row
Set nextrow = Fws.Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
With nextrow
.Offset(0, -1).Value = ID.Value + 1
.Value = Bws.Range("V3").Value
.Offset(0, 1).Value = Bws.Range("V4").Value
.Offset(0, 2).Value = Bws.Range("V5").Value
.Offset(0, 3).Value = Bws.Range("V6").Value
.Offset(0, 4).Value = Bws.Range("V7").Value
.Offset(0, 5).Value = Bws.Range("AE3").Value
.Offset(0, 6).Value = Bws.Range("AE4").Value
.Offset(0, 7).Value = Bws.Range("AE5").Value
.Offset(0, 8).Value = Bws.Range("AE7").Value
.Offset(0, 9).Value = Bws.Range("AN3").Value
.Offset(0, 10).Value = Bws.Range("AN4").Value
.Offset(0, 11).Value = Bws.Range("AN5").Value
.Offset(0, 12).Value = Bws.Range("AN6").Value
.Offset(0, 13).Value = Bws.Range("AN7").Value
.Offset(0, 14).Value = Bws.Range("AZ3").Value
.Offset(0, 15).Value = Bws.Range("BD3").Value
.Offset(0, 16).Value = Bws.Range("AZ4").Value
.Offset(0, 17).Value = Bws.Range("BD4").Value
.Offset(0, 18).Value = Bws.Range("AZ5").Value
.Offset(0, 19).Value = Bws.Range("BD5").Value
.Offset(0, 20).Value = Bws.Range("AZ6").Value
.Offset(0, 21).Value = Bws.Range("BD6").Value
.Offset(0, 22).Value = Bws.Range("AZ7").Value
.Offset(0, 23).Value = Bws.Range("BD7").Value
End With
'run the filter to limit data
FilterRng
'select the bookings sheet
Bws.Select
'run the macro to add the bookings
Bookings
'clear the values
Clearme
'error block
On Error GoTo 0
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Sub Bookings()
'declare the variables
Dim bCell As Range, Rm As Range, Dt As Range, orange As Range
Dim dCell As Range, aCell As Range, Cl As Range, Nn As Range, ID As Range
Dim Fws As Worksheet, Bws As Worksheet
Dim x As Integer
Dim LastRow As Long
Dim oCell As Variant
Dim iCell As Variant
On Error Resume Next
'variables
Set Fws = Sheet4 'data sheet
Set Bws = Sheet2 'bookings sheet
'filter the data to limit
FilterRng
'set the range to loop through
LastRow = Fws.Range("AJ" & Rows.Count).End(xlUp).Row
Set orange = Fws.Range("AJ9:AJ" & LastRow)
'clear the values from the calendar
Bws.Range("E13:BH40").ClearContents
Bws.Range("E13:BH40").Interior.ColorIndex = xlNone
'LOOP 1"""""""""""""""""""""""""""""""
'set the variable for the number of rows and loop through
For x = 13 To 40
'set the room variable
Set Rm = Bws.Cells(x, 3)
'LOOP 2"""""""""""""""""""""""""""""'
'loop through column range
For Each dCell In Bws.Range(Cells(x, 5), Cells(x, 60))
If Not dCell Is Nothing Then
'set the date variable
Set Dt = Cells(12, dCell.Column)
'FIND FUNCTION""""""""""""""""""""
'find the rooms
Set aCell = orange.Find(What:=Rm, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
'set the room variable
Set bCell = aCell
'LOOP 3"""""""""""""""""""""""
'loop through the filtered data
Do
'find the next room with a booking
Set aCell = orange.FindNext(After:=aCell)
'establish the dates to add
If aCell.Offset(0, 1).Value <= Dt.Value And aCell.Offset(0, 3).Value >= Dt.Value Then
'set the variables
Set Cl = aCell.Cells(1, 5) 'status
Set Nn = aCell.Cells(1, 10) 'name
Set ID = aCell.Offset(0, -1) 'ID
'add the names and reassign after once
If oCell <> Nn Or iCell <> ID Then
dCell.Value = Nn
Set oCell = Nn
Set iCell = ID
End If
'add the coloring
Select Case Cl
Case "Unconfirmed"
dCell.Interior.ColorIndex = 27
Case "Confirmed"
dCell.Interior.ColorIndex = 24
Case "Paid"
dCell.Interior.ColorIndex = 4
Case "Cancelled"
dCell.Interior.ColorIndex = 38
End Select
End If
'exit when values are found
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
Else
Exit Do
End If
'
Loop 'LOOP 3 end
'
End If
End If
'
Next dCell 'LOOP 2 end
'
Next x 'LOOP 1 end
'
On Error GoTo 0
End Sub
Sub LookUp()
'declare the variable
Dim Dt As Range, Nn As Range, Rm As Range
Dim c As Range, orange As Range
Dim LastRow As Long
'set object variables
Set Nn = ActiveCell
Set Dt = Cells(12, Nn.Column)
Set Rm = Cells(Nn.Row, 3)
'set the variable range to loop through
LastRow = Sheet4.Range("D" & Rows.Count).End(xlUp).Row
Set orange = Sheet4.Range("D9:D" & LastRow)
'error handler
On Error GoTo errHandler:
'establish data is there and loop
If Not Range("E13:BH40") Is Nothing Then
For Each c In orange 'add dynamic range
'1. has a value 2.Verify Room 3.Look in date range 4. Check the name [optional]
If c.Value <> 0 And c.Offset(0, -1) = Rm.Value And c.Value <= Dt.Value And c.Offset(0, 2).Value >= Dt.Value Then 'And c.Offset(0, 8).Value = Nn
'add the values selectively to the top of the calendar
With Sheet2
.Range("H3").Value = c.Cells(1, -1).Value
.Range("V3").Value = c.Cells(1, 0).Value
.Range("V4").Value = c.Value
'.Range("V5").Value = c.Cells(1, 2).Value 'days calculated do not send
.Range("V6").Value = c.Cells(1, 3).Value
.Range("V7").Value = c.Cells(1, 4).Value
.Range("AE3").Value = c.Cells(1, 5).Value
.Range("AE4").Value = c.Cells(1, 6).Value
.Range("AE5").Value = c.Cells(1, 7).Value
'.Range("AE6").Value 'calculated value not available in data
'.Range("AE7").Value = c.Cells(1, 8).Value 'total calculated do not send
.Range("AN3").Value = c.Cells(1, 9).Value
.Range("AN4").Value = c.Cells(1, 10).Value
.Range("AN5").Value = c.Cells(1, 11).Value
.Range("AN6").Value = c.Cells(1, 12).Value
.Range("AN7").Value = c.Cells(1, 13).Value
.Range("AZ3").Value = c.Cells(1, 14).Value
.Range("BD3").Value = c.Cells(1, 15).Value
.Range("AZ4").Value = c.Cells(1, 16).Value
.Range("BD4").Value = c.Cells(1, 17).Value
.Range("AZ5").Value = c.Cells(1, 18).Value
.Range("BD5").Value = c.Cells(1, 19).Value
.Range("AZ6").Value = c.Cells(1, 20).Value
.Range("BD6").Value = c.Cells(1, 21).Value
.Range("AZ7").Value = c.Cells(1, 22).Value
.Range("BD7").Value = c.Cells(1, 23).Value
End With
End If
Next c
End If
'error block
On Error GoTo 0
Exit Sub
errHandler::
MsgBox "An Error has Occurred " & vbCrLf & "The error number is: " _
& Err.Number & vbCrLf & Err.Description & vbCrLf & _
"Please notify the administrator"
End Sub
Sub DeleteMe()
'declare the variables
Dim ID As Range, c As Range, orange As Range
Dim LastRow As Long
'set the object variable
Set ID = Sheet2.Range("H3")
'stop screen flicker
Application.ScreenUpdating = False
LastRow = Sheet4.Range("B" & Rows.Count).End(xlUp).Row
Set orange = Sheet4.Range("B9:B" & LastRow)
'find the value in the range
For Each c In orange
If c.Value = ID.Value Then
'delete the row
c.EntireRow.Delete
'sort the data
Sortit
End If
Next c
'et go home
Sheet2.Select
'update the calendar
Bookings
End Sub
Sub EditMe()
'declare the variables
Dim Bws As Worksheet, Fws As Worksheet, f As Range, wID As Variant
'turn off screen updating
Application.ScreenUpdating = False
'variables
Set Bws = Sheet2
Set Fws = Sheet4
'check for sufficent data
If Bws.Range("H3").Value = "" Or Bws.Range("V3").Value = "" Or _
Bws.Range("V4").Value = "" Or Bws.Range("AN3").Value = "" Then
MsgBox "There is insufficient data to Edit"
Exit Sub
End If
'find ID
wID = Bws.Range("H3").Value
Set f = Fws.Range("B9:B" & Fws.Range("B" & Rows.Count).End(xlUp).Row).Find(wID, , xlValues, xlWhole)
If f Is Nothing Then
MsgBox "ID does not exists"
Exit Sub
End If
With f
.Offset(0, 1).Value = Bws.Range("V3").Value
.Offset(0, 2).Value = Bws.Range("V4").Value
.Offset(0, 3).Value = Bws.Range("V5").Value
.Offset(0, 4).Value = Bws.Range("V6").Value
.Offset(0, 5).Value = Bws.Range("V7").Value
.Offset(0, 6).Value = Bws.Range("AE3").Value
.Offset(0, 7).Value = Bws.Range("AE4").Value
.Offset(0, 8).Value = Bws.Range("AE5").Value
.Offset(0, 9).Value = Bws.Range("AE7").Value
.Offset(0, 10).Value = Bws.Range("AN3").Value
.Offset(0, 11).Value = Bws.Range("AN4").Value
.Offset(0, 12).Value = Bws.Range("AN5").Value
.Offset(0, 13).Value = Bws.Range("AN6").Value
.Offset(0, 14).Value = Bws.Range("AN7").Value
.Offset(0, 15).Value = Bws.Range("AZ3").Value
.Offset(0, 16).Value = Bws.Range("BD3").Value
.Offset(0, 17).Value = Bws.Range("AZ4").Value
.Offset(0, 18).Value = Bws.Range("BD4").Value
.Offset(0, 19).Value = Bws.Range("AZ5").Value
.Offset(0, 20).Value = Bws.Range("BD5").Value
.Offset(0, 21).Value = Bws.Range("AZ6").Value
.Offset(0, 22).Value = Bws.Range("BD6").Value
.Offset(0, 23).Value = Bws.Range("AZ7").Value
.Offset(0, 24).Value = Bws.Range("BD7").Value
End With
FilterRng 'run the filter to limit data
Bws.Select 'select the bookings sheet
Bookings 'run the macro to add the bookings
Clearme 'clear the values
End SubAttachments
Last edited by a moderator:
