Сделайте клетки красными, если они столкнулись

Question

Я пытаюсь предотвратить двойное бронирование номера с использованием цветовой кодировки.

Столбец идентификаторов номеров содержит дубликаты и не имеет порядка. Оранжевые ячейки вдоль ряда показывают даты, на которые была забронирована комната, как вы можете видеть на скриншоте ниже:

---

---

Я хочу, чтобы ячейка покраснела, если в тот же день в том же номере есть другое бронирование. Например, если группа А забронировала номер с 14 по 16 октября, а затем группа Б - с 16 по 18 октября, я хочу, чтобы номера с 14 по 15 и с 17 по 18 отмечены оранжевым цветом, если они были забронированы, и 16-го отмечены красным цветом, если они забронированы дважды.

Я подправил некоторый код, полученный из другого поста, но он, кажется, только проверяет / ссылается на первый дублированный идентификатор комнаты, это означает, что он будет отмечать двойное бронирование красным, если есть только два бронирования для этой комнаты и даты, если естьбольше это не будет считаться двойным бронированием.

Sub Tester()

    Dim lastRow As Long
    Dim sht As Worksheet, rng As Range
    Dim dict As Object, dict2 As Object, v, c As Range, c2 As Range
    Dim FindFirstOrangeCell As Integer, FindEndOfOrangeCell As Integer
    Dim p As Long, l As Variant, AddOne As Integer, z As String

    For d = 0 To 10
        Set dict = CreateObject("scripting.dictionary")
        Set dict2 = CreateObject("scripting.dictionary")
        With Sheets("Schedule")
            Set rng = .Range("D2:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
        End With

        For Each c In rng.Cells
            v = c.Value
            FindFirstOrangeCell = 1
            If Len(v) > 0 Then
                Do Until c.Offset(, FindFirstOrangeCell).Interior.ColorIndex = 44 Or c.Offset(, FindFirstOrangeCell).Interior.ColorIndex = xlColorIndexNone
                    FindFirstOrangeCell = FindFirstOrangeCell + 1
                Loop

            End If
            Set c2 = c.Offset(0, FindFirstOrangeCell)
            If Len(v) > 0 Then
                If c2.Interior.ColorIndex = 44 Or c2.Interior.ColorIndex = 3 Then
                    FindEndOfOrangeCell = 1
                    Do Until c2.Offset(, FindEndOfOrangeCell).Interior.ColorIndex = 4
                        FindEndOfOrangeCell = FindEndOfOrangeCell + 1
                    Loop

                    If dict.exists(v) Then
                        If dict2.exists(dict(v)) Then
                            If Not dict2(dict(v)) Is Nothing Then

                                 For p = 0 To FindEndOfOrangeCell - 1
                                    Cells(1, dict2(dict(v)).Column).Select
                                     If Cells(1, dict2(dict(v)).Column) = Cells(1, c2.Column + p) Then
                                         dict2(dict(v)).Interior.ColorIndex = 3
                                         Cells(c2.Row, c2.Column + p).Interior.ColorIndex = 3
                                     End If

                                     If Cells(1, dict2(dict(v)).Column + p) = Cells(1, c2.Column + AddOne) Then
                                         Cells(dict2(dict(v)).Row, dict2(dict(v)).Column + p).Interior.ColorIndex = 3
                                         Cells(c2.Row, c2.Column + AddOne).Interior.ColorIndex = 3
                                         AddOne = AddOne + 1
                                     End If
                                 Next p
                                 p = 0
                                 AddOne = 0
                            End If
                        End If
                    Else
                        Set dict(v) = c2
                        Set dict2(dict(v)) = c2
                    End If
                End If
            End If
        Next c
    Next d

End Sub

Я новичок в VBA, поэтому если вы видите какие-либо плохие практики, которые замедляют мой код или делают его плохим, пожалуйста, дайте мне знать, как я могуулучшить.

Я также разместил этот вопрос на другом форуме здесь

Здесь - это образец файла, который поможет понять данные.

Answer 1

Я пытался найти проблему в вашем коде, но в итоге я просто переписал все это, как вы можете видеть ниже.

Я знаю, что одна из проблем была в том, откуда вы пытались получить диапазон всех номеров. Вы использовали первый столбец, который заканчивается объединенной ячейкой, и когда VBA сталкивается с ними, он берет ссылку на верхнюю левую ячейку, и это обрезало последние две строки вашего листа в проверках.

Public Sub Tester()

    Dim roomRange As Range
    Dim roomCell As Range
    Dim roomNum As Long
    Dim bookingStart As Long
    Dim bookingEnd As Long
    Dim bookingRange As Range
    Dim bookingCell As Range
    Dim bookingDict As Object
    Set bookingDict = CreateObject("Scripting.Dictionary")
    Dim cellColour As Long

    With Sheets("Schedule") 'Get all room numbers
        Set roomRange = .Range("C2:C" & .Cells(.Rows.Count, 3).End(xlUp).Row)
    End With

    For Each roomCell In roomRange.Cells
        roomNum = roomCell.Value
        If Len(roomNum) > 0 Then

            'Find where booking starts
            bookingStart = 1
            cellColour = roomCell.Offset(0, bookingStart).Interior.ColorIndex
            Do Until cellColour = 44 Or cellColour = xlColorIndexNone Or cellColour = 3
                bookingStart = bookingStart + 1
                cellColour = roomCell.Offset(0, bookingStart).Interior.ColorIndex
            Loop

            'If there was a booking start
            If cellColour <> xlColorIndexNone Then
                'Find where booking ends
                bookingEnd = bookingStart
                cellColour = roomCell.Offset(0, bookingEnd + 1).Interior.ColorIndex
                Do Until cellColour <> 44 And cellColour <> 3
                    bookingEnd = bookingEnd + 1
                    cellColour = roomCell.Offset(0, bookingEnd + 1).Interior.ColorIndex
                Loop

                'Get booking cells
                Set bookingRange = Range(Cells(roomCell.Row, bookingStart + 3), Cells(roomCell.Row, bookingEnd + 3))
                For Each bookingCell In bookingRange.Cells

                    'If room already booked
                    If bookingDict.exists(roomNum & bookingCell.Column) Then
                        bookingCell.Interior.ColorIndex = 3
                        bookingDict(roomNum & bookingCell.Column).Interior.ColorIndex = 3
                    Else 'If this is the first booking
                        bookingDict.Add roomNum & bookingCell.Column, bookingCell
                    End If

                Next bookingCell
            End If
        End If
    Next roomCell
End Sub

Еслиу вас есть еще какие-то проблемы, просто оставьте мне комментарий, и я вам перезвоню.