Option Explicit
Sub Date_Finder()
Dim Wb As Workbook
Dim Ws As Worksheet
Dim LookVal, MaxDate, MinDate, CloseDate, x, y As Double
Dim LastRow, i As Long
Dim Rng, c As Range
Dim DateArray() As Variant
Set Wb = ActiveWorkbook
Set Ws = Wb.Worksheets("Date")
With Ws
LastRow = .Range("B65536").End(xlUp).Row
Set Rng = .Range("B1:B" & LastRow)
LookVal = CDbl(.Range("A1").Value)
End With
MaxDate = WorksheetFunction.Max(Rng)
MinDate = WorksheetFunction.Min(Rng)
ReDim DateArray(1 To LastRow)
If LookVal < MaxDate Then
If LookVal > MinDate Then
For Each c In Rng
i = i + 1
DateArray(i) = Abs(DateDiff("d", CDbl(c), LookVal))
Next c
CloseDate = WorksheetFunction.Min(DateArray())
x = LookVal + CloseDate
y = LookVal - CloseDate
With Rng
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:=x
.FormatConditions(1).Interior.ColorIndex = 3
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:=y
.FormatConditions(2).Interior.ColorIndex = 3
End With
Else
With Rng
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:=MinDate
.FormatConditions(1).Interior.ColorIndex = 3
End With
End If
Else
With Rng
.FormatConditions.Delete
.FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _
Formula1:=MaxDate
.FormatConditions(1).Interior.ColorIndex = 3
End With
End If
End Sub
|