0

我有以下问题要解决，以提高代码执行任务的速度。

我有一张桌子，上面有 Hire Cars 的名称和两个日期——从和到。我需要检查范围（比如 10k 行）并突出显示所有重叠的日期。

没有租车 从 到

1 ABC 12 月 1 日 12 月 12 日
2 ABC 12 月 14 日 12 年 1 月 15 日
3 ABC 12 月 25 日 4 DEF 2 月 12 日
4 DEF 12 月 12 日 12 月 12 日
5 DEF 1 月 12 日 2 月 12 日
6 DEF 12 月 14 日 2012 年 1 月 15 日

对于租车 DEF 有重叠的日子，事实上我需要能够突出显示重复计算，以便用户能够快速识别和纠正。

这是我开发的代码。问题是，如果你有一个 10k 行的范围，它会非常慢。

我正在使用带有 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"

结束功能

4

2 回答 2

0

最快的方法是对表格进行排序（第一顺序：汽车，第二顺序：从日期）

然后对于每条线：如果上面的线是同一辆车并且上面的to-date大于当前线的from-date，那么就会发生碰撞。

您可以使用 VBA 或 Excel-Formulas 执行这些步骤。

于 2013-01-25T05:56:42.073 回答
0

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:

enter image description here

EDIT AS PER OP'S COMMENT

  1. Transpose the sorted data into the same range as per input data, so remove offset(0,4):
  2. Add 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
于 2013-01-25T07:15:58.983 回答