Excel

The Closest Date Match Finder

Ease of Use

Easy

Version tested with

2003 

Submitted by:

MaximS

Description:

This macro will help you to search through the range for the closest match to given date. All matching values will be highlighted on red. 

Discussion:

We can use this code any time we want to establish when last order was picked after or before given date. It will highlight only the closest match or few matches (i.e. same date/s as given or dates with same day difference +2/-2) . It doesn't matter if range is asorted or not. 

Code:

instructions for use

			

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 'You can change Workbook or Worksheet 'where value will be looked for Set Wb = ActiveWorkbook Set Ws = Wb.Worksheets("Date") With Ws 'You can change column letter where match can be found 'and change 1 to 2 if you have a header LastRow = .Range("B65536").End(xlUp).Row Set Rng = .Range("B1:B" & LastRow) 'You can change reference to the cell which will be 'used to find the match LookVal = CDbl(.Range("A1").Value) End With 'Looking for Max and Min date within the renge MaxDate = WorksheetFunction.Max(Rng) MinDate = WorksheetFunction.Min(Rng) 'Declaring an Array ReDim DateArray(1 To LastRow) If LookVal < MaxDate Then If LookVal > MinDate Then For Each c In Rng i = i + 1 'This will create an Array with differences 'beetween looked value and values within the range DateArray(i) = Abs(DateDiff("d", CDbl(c), LookVal)) Next c 'This will give you 2 the closest values CloseDate = WorksheetFunction.Min(DateArray()) x = LookVal + CloseDate y = LookVal - CloseDate 'This will set up conditional formating to highlight all the 'cells with matching values With Rng .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:=x 'You can change colour index here .FormatConditions(1).Interior.ColorIndex = 3 .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:=y .FormatConditions(2).Interior.ColorIndex = 3 End With Else 'This will set up conditional formating to highlight all the 'cells with matching values With Rng .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:=MinDate .FormatConditions(1).Interior.ColorIndex = 3 End With End If Else 'This will set up conditional formating to highlight all the 'cells with matching values With Rng .FormatConditions.Delete .FormatConditions.Add Type:=xlCellValue, Operator:=xlEqual, _ Formula1:=MaxDate .FormatConditions(1).Interior.ColorIndex = 3 End With End If End Sub

How to use:

  1. Copy above code.
  2. In Excel press Alt + F11 to enter the VBE.
  3. Press Ctrl + R to show the Project Explorer.
  4. Right-click desired file on left.
  5. Choose Insert >> Module.
  6. Paste code into the right pane.
  7. Press Alt + Q to close the VBE.
  8. Save workbook before any other changes.
  9. Press Alt + F8, select 'Date_Finder', press Run.
 

Test the code:

  1. From an existing workbook, save first.
  2. Press Alt + F8.
  3. Choose 'Date_Finder'.
  4. Press 'Run'.
  5. In the example file, change the date in A1 and a Change Event macro will run the code.
 

Sample File:

datefinder.zip 18.76KB 

Approved by mdmackillop


This entry has been viewed 306 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express