[英]Highlight Overlap Days Excel VBA
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.
我需要检查范围(例如1万行)并突出显示所有重叠的日期。
No Hire Car From To 从没有租车
1 ABC 01 Jan 12 12 Jan 12 1 ABC 01 Jan 12 12 Jan 12
2 ABC 14 Jan 12 15 Jan 12 2 ABC 14 Jan 12 15 Jan 12
3 ABC 25 Jan 12 02 Feb 12 3 ABC 25 Jan 12 02 Feb 12
4 DEF 01 Jan 12 12 Jan 12 4 DEF 01 Jan 12 12 Jan 12
5 DEF 12 Jan 12 02 Feb 12 5 DEF 12一月12 02二月12
6 DEF 14 Jan 12 15 Jan 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. 对于租车DEF,有很多重叠的日子,实际上我需要突出显示两次计数,以便用户可以快速识别和更正。
This is the code that I have developed. 这是我开发的代码。 The problem is that if you have a Range of 10k Rows it is extremely slow.
问题是,如果您有1万行的范围,那将非常慢。
I am using Windows 7 Ultimate with Office/Excel 2010 我在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"
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. 您可以使用VBA或Excel公式执行这些步骤。
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.
要进行此操作,必须严格按照问题中显示的样本对您的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
Output: 输出:
offset(0,4)
: offset(0,4)
: conditiona formatting
to highlight anyrow that's null within the specified range. conditiona formatting
以突出显示在指定范围内为空的任何行。 (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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.