excel - 如果发生冲突，将单元格变为红色

Question

我正在尝试使用颜色编码防止房间被重复预订。

房间 ID 列包含重复且没有顺序。沿行的橙色单元格显示房间的预订日期，如下面的屏幕截图所示:



我想要的是，如果同一天在同一个房间里有另一个预订，一个单元格会变成红色。例如，如果 A 组在 10 月 14 日至 16 日预订，然后 B 组在 10 月 16 日至 18 日预订，我希望 14 日至 15 日和 17 日至 18 日标记为橙色以表示被预订，而 16 日标记为红色表示重复预订。

我已经调整了我从另一个帖子中获得的一些代码，但它似乎只检查/引用第一个重复的房间 ID，这意味着只要该房间和日期只有两个预订，它就会将重复预订标记为红色，如果有更多它不会算作双重预订。

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 新手，所以如果您发现任何会减慢我的代码或使其看起来很糟糕的不良做法，请告诉我如何改进。

我也将此问题发布到另一个论坛 here

Here是帮助理解数据的示例文件。

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

如果您对此有任何进一步的问题，请给我留言，我会回复您。