突出顯示重疊天數Excel VBA

Question

我有以下問題需要解決，以提高代碼執行任務的速度。

我有一個表，上面有出租汽車的名稱和兩個日期-從和到。 我需要檢查范圍（例如1萬行）並突出顯示所有重疊的日期。

從沒有租車

1 ABC 01 Jan 12 12 Jan 12
2 ABC 14 Jan 12 15 Jan 12
3 ABC 25 Jan 12 02 Feb 12
4 DEF 01 Jan 12 12 Jan 12
5 DEF 12一月12 02二月12
6 DEF 14 Jan 12 15 Jan 12

對於租車DEF，有很多重疊的日子，實際上我需要突出顯示兩次計數，以便用戶可以快速識別和更正。

這是我開發的代碼。 問題是，如果您有1萬行的范圍，那將非常慢。

我在Office / Excel 2010中使用Windows 7 Ultimate

    Function CheckOverlap(StartLine, EndLine, StartColumn)

Dim i As Integer, y As Integer
Dim DateToCompare
Dim HireCar
Dim Count As Integer
Dim Msg, Style, Title, Response

'Check StartDate Column
For i = StartLine To EndLine

    DateToCompare = Cells(i, StartColumn)
    HireCar = Cells(i, 2)
    For y = StartLine To EndLine
        'If we are at the same line with DateToCompare cell then we should not perform any check
        If i <> y Then    
            If DateToCompare >= Cells(y, StartColumn) And DateToCompare <= Cells(y, StartColumn + 1) And HireCar = Cells(y, 2) Then
                'We should highlight both cells that contain overlapping dates
                ActiveSheet.Cells(i, StartColumn).Interior.Color = 5296274
                ActiveSheet.Cells(y, StartColumn).Interior.Color = 5296274
            End If
        End If
    Next y
Next i

HireCar = 0

'Check EndDate Column
For i = StartLine To EndLine

    DateToCompare = Cells(i, StartColumn + 1)
    HireCar = Cells(i, StartColumn - 1)
    For y = StartLine To EndLine
        'If we are at the same line with DateToCompare cell then we should not perform any check
        If i <> y Then    
            If DateToCompare >= Cells(y, StartColumn) And DateToCompare <= Cells(y, StartColumn + 1) And HireCar = Cells(y, StartColumn - 1) Then
                'We should highlight both cells that contain overlapping dates
                ActiveSheet.Cells(i, StartColumn + 1).Interior.Color = 5296274
                ActiveSheet.Cells(y, StartColumn + 1).Interior.Color = 5296274
            End If
        End If
    Next y
Next i


'Last check: If the starting and ending date are the same
For i = StartLine To EndLine
    If Cells(i, StartColumn) - Cells(i, StartColumn + 1) = 0 Then
        ActiveSheet.Cells(i, StartColumn).Interior.Color = 5296274
        ActiveSheet.Cells(i, StartColumn + 1).Interior.Color = 5296274
    End If
Next i

' If there are no Overlap Days in Database skip filtering
' StartDate and EndDate Column
' Count Cells with Interior.Color = 5296274 (Green Colour)
Count = 0

For i = StartLine To EndLine
    If Cells(i, StartColumn).Interior.Color = 5296274 Then
        Count = Count + 1
    End If
Next i

' Msg if Database has no Overlap Days
Msg = "Validation check completed. There are 'NO' Overlap Days"
Style = vbOKOnly
Title = "Cash Flow"

' Require on Error Resume Next in case Database is NOT filtered
On Error Resume Next
If Count = 0 Then
    ActiveSheet.ShowAllData
    Response = MsgBox(Msg, Style, Title)
    Exit Function
Else
    Call Filter_Colour
End If

MsgBox "Any Green highlights indicate Overlap Days"

結束功能

Answer 1

最快的方法是對表格進行排序（一階：汽車，二階：起始日期）

然后，對於每條線：如果上面的線是同一輛車，並且從上方的截止日期大於當前線的起始日期，則發生碰撞。

您可以使用VBA或Excel公式執行這些步驟。

Answer 2

這是一個簡單的算法，當后面的行有重疊時，向您顯示空白。 要進行此操作，必須嚴格按照問題中顯示的樣本對您的CAR列進行排序。

Option Explicit

'-- assuming the CAR names column is sorted
'-- so each car block in one place
'-- run on button click event

Sub FindOverlaps()
Dim i As Integer, j As Integer
Dim vInput As Variant
Dim rng As Range

Set rng = Sheets(2).Range("B2:E7")
vInput = WorksheetFunction.Transpose(WorksheetFunction.Transpose(rng))

For i = LBound(vInput) To UBound(vInput) - 1
    For j = LBound(vInput) + 1 To UBound(vInput)
        If vInput(i, 2) = vInput(j, 2) Then
            If vInput(i, 4) = vInput(j, 3) Then
                vInput(j, 3) = ""
                vInput(j, 4) = ""
            End If
        End If
    Next j
Next i

rng.Offset(0, 6).Resize(UBound(vInput), UBound(Application.Transpose(vInput))) = vInput

End Sub

輸出：

---

根據OP的評論進行編輯

1. 將排序后的數據轉置為與每個輸入數據相同的范圍 ，因此請刪除offset(0,4) ：
2. 添加conditiona formatting以突出顯示在指定范圍內為空的任何行。 （否則整個工作表將在空白單元格處着色）

代碼更改：

rng.Offset(0, 6).FormatConditions.Delete
rng.Offset(0, 6).FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
        Formula1:="="""""
rng.Offset(0, 6).FormatConditions(1).Interior.ColorIndex = 20