Sort and copy data based on a date - excel

Question

I'm trying to create a macro that would allow me to extract data from an array to send an email.
The sorting must be done according to the comments. The goal is to detect the date of the day, for example today 22/08/2022, and to extract the line in another page by erasing in the comment box, the comments which are not dated today , ie have the whole line with the last comment in the comment box. On the other hand, if there is no comment dating from today, the line must not be selected or copied.
However, no matter what code I enter, I cannot sort the data according to the date and only retrieve today's comment, knowing that in this excel I only have a few lines but I have to be able to use it for 1000 rows.
How should I go about it?
Thank you and have good day
My example table
The result that I try to have

Answer 1

Solution
Option Explicit
Sub TodaysComments()
Dim srcWs As Worksheet
Dim destWs As Worksheet
Dim myCell As Range
Dim rngToCopy As Range
' Set source and find comments column
Set srcWs = Worksheets("Source")
Set myCell = srcWs.Cells.Find("Commentaires")
If myCell Is Nothing Then
MsgBox "Cannot find column 'Commentaires'!", vbCritical
Exit Sub
End If
' Set and clear destination
Set destWs = Worksheets("Filtered")
destWs.Cells.Clear
' Copy Header
RngCopy CurrentRow(myCell), destWs.Range("A1")
' Loop over comments
NextCell myCell
Do While myCell.Value <> ""
' Search for today's date
If Not myCell.Find(Today) Is Nothing Then
' Aggregate rows to copy
Set rngToCopy = RngUnion(rngToCopy, CurrentRow(myCell))
End If
NextCell myCell
Loop
' No comments today
If rngToCopy Is Nothing Then
MsgBox "No 'Commentaires' rows meet criteria!", vbInformation
Exit Sub
End If
' Copy rows to destination
RngCopy rngToCopy, destWs.Range("A2")
' Clear old comments from destination
Set myCell = destWs.Cells(2, myCell.Column)
Do While myCell.Value <> ""
ClearOldComments myCell
NextCell myCell
Loop
MsgBox "Done!", vbInformation
End Sub
Private Sub RngCopy(SrcRng As Range, DestRng As Range)
SrcRng.Copy
DestRng.PasteSpecial xlPasteAll
DestRng.Range("A1").PasteSpecial xlPasteColumnWidths
Application.CutCopyMode = False
End Sub
Private Function CurrentRow(myCell As Range) As Range
Set CurrentRow = Range(myCell, myCell.Worksheet.Cells(myCell.Row, 1))
End Function
Private Sub NextCell(myCell As Range)
Set myCell = myCell.Offset(1, 0)
End Sub
Function RngUnion(Rng1 As Range, Rng2 As Range) As Range
If Rng2 Is Nothing Then Err.Raise 91 ' Object variable not set
If Rng1 Is Nothing Then
Set RngUnion = Rng2
Exit Function
End If
Set RngUnion = Union(Rng1, Rng2)
End Function
Private Sub ClearOldComments(myCell As Range)
Dim Comments As Variant
Dim i As Long
Comments = VBA.Split(myCell.Value, vbNewLine)
For i = LBound(Comments) To UBound(Comments)
' NOTE: We assume there is only one comment per day.
If InStr(Comments(i), Today) Then
myCell.Value = Comments(i)
Exit Sub
End If
Next
' Should not be possible
Err.Raise 93 ' Invalid pattern string
End Sub
Function Today() As String
Today = FormatDateTime(Date, vbGeneralDate)
End Function