I have the following problem to solve to increase the speed at which the code performs the task.
I have a table with names of Hire Cars and two dates - From and To. I need to go through the range (say 10k rows) check and highlight all overlapping dates.
No Hire Car From To
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 Jan 12 02 Feb 12
6 DEF 14 Jan 12 15 Jan 12
For hire car DEF there are overlapping days, double counting in fact which i need to be able to highlight so that the user can quickly identify and correct.
This is the code that I have developed. The problem is that if you have a Range of 10k Rows it is extremely slow.
I am using Windows 7 Ultimate with Office/Excel 2010
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"
End Function
The fastest approach would be to sort the table (first order: cars, second order: from-date)
Then for each line: there is a collision iif the line above is the same car and the to-date from above is larger than the from-date of the current line.
You can do these steps either with VBA or Excel-Formulas.
Here is a simple algo to show you a blank when there's an overlap on the latter rows. To run this, it's strictly assumed that your CAR column is sorted as per sample shown in the question.
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
Output:
offset(0,4)
: conditiona formatting
to highlight anyrow that's null within the specified range. (otherwise entire sheet will be coloured where empty cells are) Code changes:
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.