vba loop through string to find date

Question

I am trying to loop through filenames to find a date. I do not have a specific date I'm looking for, just trying to pull a date if one exists in the filename . Problem is that the users don't use the same format everytime so I have everything from 1-1-14 to 01-01-2014 to consider. I wrote a function for this but when the date in the file name is 06-23-2014 I get a return of 6/23/201. Example file names are "F2 A-Shift 06-23-2014 Daily Sustaining Report.xls" and "F1C-Shift 6-25-14 Daily Sustaining Report.xls". Any help on a viable solution would be greatly appreciated.

Function GetDate(strName As String) As Date

    Dim intLen As Integer, i As Integer

    intLen = Len(strName)

    If intLen <= 10 Then Exit Function

    For i = 1 To intLen - 10
        If IsDate(Mid(strName, i, 10)) = True Then
           GetDate = (Mid(strName, i, 10))
           Exit Function
        End If
    Next i

    GetDate = "1/1/2001"
End Function

Answer 1

You can always create your own RegEx function to simplify:

Function RegEx(Target As String, RegExpression As String, _
               Optional ReplaceString As String, Optional xIgnoreCase As Boolean, _
               Optional xGlobal As Boolean, Optional xMultiLine As Boolean)

    Dim regexOne As Object
            
    Set regexOne = New RegExp
    regexOne.Pattern = RegExpression
    If xIgnoreCase Then regexOne.IgnoreCase = xIgnoreCase
    If xGlobal Then regexOne.Global = xGlobal
    If xMultiLine Then regexOne.MultiLine = xMultiLine
    
    If regexOne.Test(Target) Then
        If IsMissing(ReplaceString) Then
            RegEx = regexOne.Execute(Target)
        Else
            RegEx = regexOne.Replace(Target, ReplaceString)
        End If
    End If
        
End Function

Answer 2

Useful input thanks !

I have tweaked it to accomodate my needs and the result reads as follows:

Sub DateGet()

Dim datDate                         As Date
Dim intDay                          As Integer
Dim intMth                          As Integer
Dim intYr                           As Integer
Dim i                               As Integer
Dim strSeparator                    As String

datDate = DateStrip(Selection.Value)

For i = 1 To Len(datDate)
    If Not IsNumeric(Mid(datDate, i, 1)) Then
        strSeparator = Mid(datDate, i, 1)
        Exit For
    End If
Next
intDay = Mid(datDate, 1, i - 1)
intMth = Mid(datDate, i + 1, InStr(i + 1, datDate, strSeparator) - i - 1)
intYr = Mid(datDate, InStr(i + 1, datDate, strSeparator) + 1, 4)
'Debug.Print intDay & strSeparator & intMth & strSeparator & intYr

End Sub

Function DateStrip(strName As String) As Date Dim intLen As Integer Dim i As Integer Dim S As String

intLen = Len(strName)
If intLen <= 10 Then Exit Function
For i = 1 To intLen
    If Mid(strName, i, 1) Like "#" Then
        S = Mid(strName, i, InStr(i + 1, strName, " ") - i)
        If IsDate(S) Then
            DateStrip = S
            Exit Function
        End If
    End If
Next i

End Function

Answer 3

Your first problem is you are assuming that a date is always 10 characters and 2nd is you are checking for a valid date and as soon as you get a valid date you are existing your loop.

The code you are using will never recognize 6-1-14 as a valid date because even with a trailing and leading space, it will never be a valid date when you are looking at blocks of 10 characters.

The issue with your 2nd problem lies with If IsDate(Mid(strName, i, 10)) = True Then

There are a number of things Excel does too well and one of which is guess what you are trying to do. You are assuming that a leading space on a date such as " 06-23-201" would not be considered a valid date, but you are incorrect. The IsDate function sees this as a valid date so your loop exits before you even get to the "4". This is why you are only getting 6/23/201.

So to solve both of your problems, you need to modify your logic. Instead of focusing on checking 10 characters at a time, you should use the fact that your dates will always seem to have a leading or trailing space.

Function GetDate(strName As String) As Date

    Dim FileNameParts as Variant
    Dim part as Variant

    FileNameParts  = Split(strName," ")

    For Each part in FileNameParts  
        If IsDate(part ) = True Then
           GetDate = part
           Exit Function
        End If
    Next    

    GetDate = "1/1/2001"
End Function

Answer 4

The reason you get the result you see in your function is because the IsDate function ignores leading spaces. So " 1/1/01" will be seen as a date. In order to make your function work, you would probably need to check that; perhaps by ensuring the the first and last characters are digits; determining the length; and ensuring that there are spaces around the date.

Another method would be to use a regular expression to parse all that out. Without checking for invalid dates (e.g. feb 31), the following is one way to do that:

Option Explicit
Function GetDate(S As String) As Date
  Dim RE As Object, MC As Object
Set RE = CreateObject("vbscript.regexp")
With RE
    .Pattern = "\b(0?[1-9]|1[012])[- /.](0?[1-9]|[12][0-9]|3[01])[- /.](19|20)?[0-9]{2}\b"
    If .test(S) = True Then
        Set MC = .Execute(S)
        GetDate = MC(0)
    Else
        GetDate = "1/1/2001"
    End If
End With
End Function

With a little effort, I have modified your original approach slightly which I believe should also work:

Function GetDate(strName As String) As Date
  Dim intLen As Integer, i As Integer
  Dim S As String

    intLen = Len(strName)
    If intLen <= 10 Then Exit Function
    For i = 1 To intLen - 10
        If Mid(strName, i, 1) Like "#" Then
            S = Mid(strName, i, InStr(i, strName, " ") - 1)
            If IsDate(S) Then
                GetDate = S
                Exit Function
            End If
        End If
    Next i
    GetDate = "1/1/2001"
End Function

Answer 5

You can use

Function DateValueFn(Str as String) as Date
    On Error Goto ERRORHANDLER
    DateValueFn = DateValue(Str)
    Exit Function
ERRORHANDLER:
    DateValueFn = 0
End Function

Now if the user gives an invalid output, this function returns 0, else the date. You may do a check wherever it gets called and use it.

Now since the filenames are stored as SomestringDateString where both substrings are of variable length, the user will need to run a loop to check all substrings such that (following code exists in a for loop)

SubStr = Right(FileName, i)    'i loops from 6 to 16 or till length of FileName
DtVal = DateValueFn(SubStr)
If DtVal !=0
    ' Date Found, do something, raise a flag perhaps and inspect DtVal
    Exit For
Else
    ' Date Not Found, continue looking, maybe raise a flag if no date found for all i
End if

---

And Finally if filenames are in a format Somestring1DateStringSomestring2 the above loop needs to become a double-doop with Right replaced by a Mid function so all possible subsets of the string, from characters 1:6 to characters N-5:N and then 1:7 to N-6:N, etc. need to be checked.