Extract Most Current Date from Text String Cell

[ripina]

Have many rows with dated notes/comments in a single cell. Need to extract the notes associated with the most recent date. See example below:
[TABLE="width: 500"]
<tbody>[TR]
[TD]2/1/18 - comment one comment one 1/27/18 - comment two comment two 12/25/17 - comment three comment three[/TD]
[TD](result) 2/1/18 - comment one comment one[/TD]
[/TR]
[TR]
[TD]10/31/17 - notesnotes notes 11/1/17 - samplesamplesample [/TD]
[TD](result) 11/1/17 - samplesamplesample[/TD]
[/TR]
</tbody>[/TABLE]

 

[JLGWhiz]

This might work if your comments are separated by a line feed. I took the liberty of pasting the extracted data to sheet 2. Change as desired.

Sub t()
Dim spl As Variant, c As Range, dt As Variant
With Sheets("Sheet1")
    For Each c In .Range("A2", .Cells(Rows.Count, 1).End(xlUp))
        If InStr(c.Value, Chr(10)) = 0 Then
            Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)(2) = c.Value
            Exit For
        End If
        spl = Split(c.Value, Chr(10))
        For i = LBound(spl) To UBound(spl) - 1
            If IsEmpty(nt) Or nt = "" Then
                nt = spl(i)
            End If
            dt = Trim(Left(nt, InStr(nt, "-") - 1))
                If DateValue(dt) > DateValue(Trim(Left(spl(i + 1), InStr(spl(i + 1), "-") - 1))) Then
                    nt = nt
                Else
                    nt = spl(i + 1)
                End If
        Next
        If Not IsEmpty(nt) Then
            Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp)(2) = nt
        End If
        dt = ""
        nt = ""
    Next
End With

 

[Leith Ross]

Hello ripina,

If you need this to work like a worksheet formula, here is a UDF (User Defined Function) macro.

Private RegExp  As Object


Function GetMostRecentNote(ByRef Cell As Range)


    Dim Latest  As Variant
    Dim Matches As Object
    Dim n       As Long
    Dim RegExp  As Object
    Dim Text    As String
        
        Application.Volatile
        
        If RegExp Is Nothing Then
            Set RegExp = CreateObject("VBScript.RegExp")
            RegExp.Global = True
            RegExp.Pattern = "(\d{1,2}\/\d{1,2}\/\d{1,2})+"
        End If
            
            Latest = 0
            Set Matches = RegExp.Execute(Cell)
            
            For n = 0 To Matches.Count - 1
                If CDate(Matches(n)) > Latest Then
                    Latest = CDate(Matches(n))
                    If n < Matches.Count - 1 Then
                        Text = Mid(Cell, Matches(n).FirstIndex + 1, Matches(n + 1).FirstIndex)
                    Else
                        Text = Mid(Cell, Matches(n).FirstIndex + 1, Len(Cell) - Matches(n).FirstIndex + 1)
                    End If
                End If
            Next n
        
       GetMostRecentNote = Text
        
End Function

Example:
Cell A1 2/1/18 - comment one comment one 1/27/18 - comment two comment two 12/25/17 - comment three comment three
Cell D1 formula =GetMostRecentNote(A1)

 

[ripina]

Leith- this works perfectly, thank you so much for your help with this. I really need to learn more about VBA and UDFs.

 

[Leith Ross]

Hello ripina,

You're welcome. Glad I could help.