How to scrub through a string to match a date - excel

Question

So I have built a workbook for validation and publishing sets of other workbooks/reports out to another location. Part of the process is for the user to enter a date value into a cell, and that is checked for within the reports the user has listed.
Date formatting doesn't matter because I am doing a date type to date type comparison in my validation function.
Basically:
if CDate(UserVal) = CDate(ValFromString) then
'do stuff
end if
The other common occurrence is the date has always been at the end of the string in the compared cell.
Example:
Current 52 Weeks Ending 04/10/15
Cur 52 Weeks Apr 4, 2015
Current 52 WE 4-Apr-15
No matter what format the user inputs into the validation cell, I just keep stripping from the right until isdate pops true.
I know I have been lucky in this setup, with the date always being at the end. I've now run into two instances that do not work.
CURRENT 12 WEEKS (4 WEEKS ENDING 04/11/15)
4 WE 04/11/2015 Current 12
In the first, the parenthesis breaks my right() stripping. In the second, the date is in the middle. The format of the date value differs from report to report, so I cannot do a instr(1, String, cstr(UserVal)) to accomplish the check. The location of the date is not set in stone either, as it could be at the end, beginning, or anywhere in the middle of the string.
Short way of putting it, is there an easy way to scan a string for a specified date value, agnostic of format?

Answer 1

Here is my feeble attempt :D
This will match a wide range of date formats
Hope this helps
Sub Sample()
Dim MyAr(1 To 5) As String, frmt As String
Dim FrmtAr, Ret
Dim i As Long, j As Long
MyAr(1) = "(This 01 has 04/10/15 in it)"
MyAr(2) = "This 04/10/2015"
MyAr(3) = "4-Apr-15 is a Sample date"
MyAr(4) = "(Apr 4, 2015) is another sample date"
MyAr(5) = "How about ((Feb 24 2012)) this?"
'~~> Various date formats
'~~> YYYY (/????) grouped together. Will search for this first
frmt = "??/??/????|?/??/????|??/?/????|??-??-????|"
frmt = frmt & "?-??-????|??-?-????|??? ?? ????|??? ? ????|"
frmt = frmt & "?-???-????|???-??-????|???-?-????|"
frmt = frmt & "??? ??, ????|??? ?, ????|"
'~~> YY (??) grouped after. Will search for this later
frmt = frmt & "??-???-??|?-???-??|??/??/??|?/??/??|??/?/??|"
frmt = frmt & "??-??-??|?-??-??|??-?-??|???-??-??|???-?-??|"
frmt = frmt & "|??? ?? ??|??? ? ??|??? ??, ??|??? ?, ??|"
FrmtAr = Split(frmt, "|")
For i = LBound(MyAr) To UBound(MyAr)
For j = 0 To UBound(FrmtAr)
'Something like =MID(A1,SEARCH("??/??/??",A1,1),8)
Expr = "=MID(" & Chr(34) & MyAr(i) & Chr(34) & ",SEARCH(" & _
Chr(34) & Trim(FrmtAr(j)) & Chr(34) & _
"," & Chr(34) & MyAr(i) & Chr(34) & ",1)," _
& Len(Trim(FrmtAr(j))) & ")"
Ret = Application.Evaluate(Expr)
If Not IsError(Ret) Then
If IsDate(Ret) Then
Debug.Print Ret
Exit For
End If
End If
Next j
Next i
End Sub
Output
EDIT
You can also use this as an Excel function
Paste this in a module
Public Function ExtractDate(rng As Range) As String
Dim frmt As String
Dim FrmtAr, Ret
Dim j As Long
ExtractDate = "No Date Found"
'~~> Various date formats
'~~> YYYY (/????) grouped together. Will search for this first
frmt = "??/??/????|?/??/????|??/?/????|??-??-????|"
frmt = frmt & "?-??-????|??-?-????|??? ?? ????|??? ? ????|"
frmt = frmt & "?-???-????|???-??-????|???-?-????|"
frmt = frmt & "??? ??, ????|??? ?, ????|"
'~~> YY (??) grouped after. Will search for this later
frmt = frmt & "??-???-??|?-???-??|??/??/??|?/??/??|??/?/??|"
frmt = frmt & "??-??-??|?-??-??|??-?-??|???-??-??|???-?-??|"
frmt = frmt & "|??? ?? ??|??? ? ??|??? ??, ??|??? ?, ??|"
FrmtAr = Split(frmt, "|")
For j = 0 To UBound(FrmtAr)
'Something like =MID(A1,SEARCH("??/??/??",A1,1),8)
Expr = "=MID(" & Chr(34) & rng.Value & Chr(34) & ",SEARCH(" & _
Chr(34) & Trim(FrmtAr(j)) & Chr(34) & _
"," & Chr(34) & rng.Value & Chr(34) & ",1)," _
& Len(Trim(FrmtAr(j))) & ")"
Ret = Application.Evaluate(Expr)
If Not IsError(Ret) Then
If IsDate(Ret) Then
ExtractDate = Ret
Exit For
End If
End If
Next j
End Function
Note: I am still working on a RegEx version which will be pretty much shorter than this...
Edit: As promised! I am sure it make me made more perfect but now I can't spend more time on this :)
RegEx Version
Sub Sample()
Dim MyAr(1 To 5) As String
MyAr(1) = "(This 01 has (04/10/15) in it)"
MyAr(2) = "This 04/10/2015"
MyAr(3) = "4-Apr-15 is a smaple date"
MyAr(4) = "(Apr 4, 2015) is another sample date"
MyAr(5) = "How about ((Feb 24 2012)) this?"
For i = 1 To 5
Debug.Print DateExtract(MyAr(i))
Next i
End Sub
Function DateExtract(s As String) As String
Dim a As String, b As String, c As String
Dim sPattern As String
sPattern = "\b(jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec)"
sPattern = sPattern & "\s(\d\d?),?\s+(\d{2,4})|(\d\d?)[\s-]("
sPattern = sPattern & "jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec"
sPattern = sPattern & ")[\s-,]\s?(\d{2,4})|(\d\d?)[-/](\d\d?)[-/](\d{2,4})\b"
With CreateObject("VBScript.RegExp")
.Global = False
.IgnoreCase = True
.Pattern = sPattern
If .Test(s) Then
Dim matches
Set matches = .Execute(s)
With matches(0)
a = .SubMatches(0) & .SubMatches(3) & .SubMatches(6)
b = .SubMatches(1) & .SubMatches(4) & .SubMatches(7)
c = .SubMatches(2) & .SubMatches(5) & .SubMatches(8)
DateExtract = a & " " & b & " " & c
End With
End If
End With
End Function

Answer 2

The following will find a date if it is there, but it may not be the date you want:
Sub INeedADate()
Dim st As String, L As Long, i As Long, j As Long
st = ActiveCell.Text
L = Len(st)
For i = 1 To L - 1
For j = 1 To L
st2 = Mid(st, i, j)
If IsDate(st2) Then
MsgBox CDate(st2)
Exit Sub
End If
Next j
Next i
End Sub
The routine generates all properly sequenced sub-strings of a string and tests each one for IsDate()
The problem is that for:
Current 52 Weeks Ending 04/10/15
It finds the sub-string:
04/1
first - which is a valid date!!
Do you want ALL valid dates within the string ???
EDIT#1:
The solution is to just run the length part of the Mid() function backwards:
Sub INeedADate()
Dim st As String, L As Long, i As Long, j As Long
st = ActiveCell.Text
L = Len(st)
For i = 1 To L - 1
For j = L To 1 Step -1
st2 = Mid(st, i, j)
If IsDate(st2) Then
MsgBox CDate(st2)
Exit Sub
End If
Next j
Next i
End Sub