[英]Highlight Overlap Days Excel VBA
我有以下问题需要解决,以提高代码执行任务的速度。
我有一个表,上面有出租汽车的名称和两个日期-从和到。 我需要检查范围(例如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"
结束功能
最快的方法是对表格进行排序(一阶:汽车,二阶:起始日期)
然后,对于每条线:如果上面的线是同一辆车,并且从上方的截止日期大于当前线的起始日期,则发生碰撞。
您可以使用VBA或Excel公式执行这些步骤。
这是一个简单的算法,当后面的行有重叠时,向您显示空白。 要进行此操作,必须严格按照问题中显示的样本对您的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
输出:
offset(0,4)
: 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.