entering dates into two cells and then receiving a corresponding range to be formatted RRS feed

  • Question

  • I am new to VBA.  I am trying to set up a reservation system using Excel.  The rows are the different rooms and the columns are the dates.  The tutorial that I am using to set up this system didn't go far enough for my liking.  Using the current code it will find use the "start date" from the data entry cell and show the name in a calendar type data range.  What I need to add is an "end date" which will then show all of the dates for that booking.  I'm not sure how to put that into the code that the tutorial already had.  Here is that code.  Any help would be greatly appreciated.



    VBA Code:

    Sub Bookings()

        Dim Rm As Range, Dt As Range, Myrng As Range, Sites As Range
        Dim endCol As Range, StCol As Range, StRow As Range, endRow As Range
        Dim Codei As Range, Col As Range
        Dim Dws As Worksheet, Cws As Worksheet
        Dim x As Integer
        Dim LastRow As Long
        Dim aCell As Range, bCell As Range, dCell As Range

        Set Cws = Sheet1
        Set Dws = Sheet2
        Set StCol = Cws.Range("I5")
        Set endCol = Cws.Range("K5")
        Set StRow = Cws.Range("M5")
        Set endRow = Cws.Range("O5")

        LastRow = Dws.Range("C" & Rows.Count).End(xlUp).Row
        Set Myrng = Dws.Range("C7:C" & LastRow)   'data sheet columns
        Cws.Range("G12:AH31").Interior.ColorIndex = xlNone
            For x = StRow To endRow
            Set Sites = Cws.Cells(x, 6)
                    For Each dCell In Cws.Range(Cells(x, StCol), Cells(x, endCol))
                If Not dCell Is Nothing Then
                    Set Dt = Cells(11, dCell.Column)
                                    Set aCell = Myrng.Find(What:=Sites, LookIn:=xlValues, _
                                           LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                                           MatchCase:=False, SearchFormat:=False)
                    If Not aCell Is Nothing Then
                        Set bCell = aCell
                            Set aCell = Myrng.FindNext(After:=aCell)
                            If aCell.Offset(0, 1).Value = Dt.Value Then
                                Set Codei = aCell.Cells(1, 4)
                                Set Col = aCell.Cells(1, 3)
                                dCell.Value = Codei
                                Select Case Col
                                    Case Cws.Range("AP9").Value
                                        dCell.Interior.ColorIndex = 27
                                    Case Cws.Range("AP10").Value
                                        dCell.Interior.ColorIndex = 24
                                    Case Cws.Range("AP11").Value
                                        dCell.Interior.ColorIndex = 4
                                    Case Cws.Range("AP12").Value
                                        dCell.Interior.ColorIndex = 38
                                End Select
                            End If
                            If Not aCell Is Nothing Then
                                If aCell.Address = bCell.Address Then Exit Do
                                Exit Do
                            End If
                    End If
                End If
            Next dCell
        On Error GoTo 0
    End Sub

    Thursday, January 29, 2015 5:15 PM