VBA/Function for complex date difference

Hi,

Can anyone help me with a VBA or function to calculate the difference between 2 or many more dates all grouped in a cell?

Based on the attached workbook and how the data is structured(all the time) it would be useful for me to get the following data:

a) How many days(or hours) have passed since creation of the Case and the date of the first comment of the Handler (date of creation of the Case = all the times the first date from the bottom, the Creator's first comment date).
b) How many days(or hours) have passed between each subsequent comment of the Handler.
c) How many comments have been totally placed by the Handler for that case.

Finally, it would be excellent to not count weekend days and if time passed is less than 1 day - show the number of hours.

Appreciate your help

the data cannot be used with this format. Every text should have its own record. Not shared in 1 cell.
youd have to run a process to strip the existing layout into correct data records.

Any help on this please? I guess it can be achieved with some sort of combination of SPLIT, for, do, MID, etc. but I have no clue

Can you give us the details of your desired results and how you calculate?

Your attachment is not valid.

Since you didn't show us your desired result and how it should be calculated, this is only my guess.

1) Select D2:F2
2) enter formula
=GetAll(C2,"Creator","Handler")
Confirm with Ctrl + Shift + Enter (array formula entry)

Function GetAll(ByVal txt As String, CName As String, HName As String)
    Dim a(2), x, i As Long, sDate As Date, eDate As Date, dif
    x = Split(txt, vbLf & vbLf)
    For i = UBound(x) To 0 Step -1
        If x(i) Like "* " & CName & "*" Then
            sDate = DateSerial(Left$(x(i), 4), Mid$(x(i), 6, 2), Mid$(x(i), 9, 2))
        ElseIf x(i) Like "* " & HName & "*" Then
            a(2) = a(2) + 1
            eDate = DateSerial(Left$(x(i), 4), Mid$(x(i), 6, 2), Mid$(x(i), 9, 2))
            dif = WorksheetFunction.NetworkDays(sDate, eDate)
            If a(0) = "" Then a(0) = dif
            a(1) = a(1) & IIf(a(1) <> "", ", ", "") & dif
        End If
    Next
    GetAll = a
End Function

That's that workbook exactly the same as the one in your post#1.

Have you tested the UDF I posted?

Jindon, the first two results are not correct:

- In D2 I get "2" days whereas if you look at the workbook, the actual difference is around 1.2 days.
- In E2 I get "2,3,3" days whereas if you look, the Handler only commented twice after his first comment with a difference of 1.6 days, respectively 2 days.
- In F2 I get "3 days". Correct.

Can you adjust the code?

Or as an alternative , can you think of a code which could extract horizontally all the occurrences of "2022....Comments)"? This way I might be able to easily do some counts and calculations afterwards.

That's why I asked you to show me the result that you want.
I don't want to do a guess work, so if you upload a workbook with your Exact result, I will think about it.

Jindon, I have attached the sample workbook with my desired results in yellow.

Option B would be the most suitable for me. Looking forward to see your solution.

Thank you!

It should look like
=IFERROR(GetAll($AU2,Column(A1)),"")

Did you also copy the code to the said workbook then I need to see your wokbook.

Originally Posted by jindon

Did you also copy the code to the said workbook then I need to see your wokbook.

Reattached the Sample including the 2 line breaks in C2. Looking forward to see your code adapted to this

Jindon, this is working splendid now. Can I have one final wish so I can have more flexibility when importing this in PBi?

Based on your same logic can you adjust the code to only show:

-in D2: the date of the first comment
-in E2: the name of the person who placed the first comment
-in F2: the date of the last comment(most recent one)
-in G2: the name of the person who placed the last comment(most recent one)

(Regardless of the number of comments in C2)

D2:
=OptionX($C2,COLUMN(A1))

Function OptionX(ByVal txt As String, ref As Long) As String
    Dim a(1 To 4), x, i As Long
    x = Application.Trim(Split(txt, vbLf))
    For i = LBound(x) To UBound(x)
        If x(i) Like "####-##-## ##:##:##*" Then
            a(1) = Replace(Left$(x(i), 16), "-", "/")
            a(2) = Trim(Split(Mid$(x(i), 23), "(")(0))
            If a(3) = "" Then
                a(3) = Replace(Left$(x(i), 16), "-", "/")
                a(4) = Trim(Split(Mid$(x(i), 23), "(")(0))
            End If
        End If
    Next
    OptionX = a(ref)
End Function

Yes, forgot

MS-Off Ver 365
Just enter
D2:
=GetAll(C2)
or
=OptionX(C2)

Function GetAll(ByVal txt As String)
    Dim a, x, i As Long, n As Long
    x = Application.Trim(Split(txt, vbLf))
    ReDim a(1 To UBound(x) + 1)
    For i = UBound(x) To LBound(x) Step -1
        If x(i) Like "####-##-## ##:##:##*" Then
            n = n + 1
            a(n) = Replace(Left$(x(i), 16), "-", "/")
            n = n + 1
            a(n) = Trim(Split(Mid$(x(i), 23), "(")(0))
        End If
    Next
    ReDim Preserve a(1 To n)
    GetAll = a
End Function

Function OptionX(ByVal txt As String)
    Dim a(1 To 4), x, i As Long
    x = Application.Trim(Split(txt, vbLf))
    For i = LBound(x) To UBound(x)
        If x(i) Like "####-##-## ##:##:##*" Then
            a(1) = Replace(Left$(x(i), 16), "-", "/")
            a(2) = Trim(Split(Mid$(x(i), 23), "(")(0))
            If a(3) = "" Then
                a(3) = Replace(Left$(x(i), 16), "-", "/")
                a(4) = Trim(Split(Mid$(x(i), 23), "(")(0))
            End If
        End If
    Next
    OptionX = a
End Function

E2:
=OptionZ(D2)

Function OptionZ(ByVal txt As String)
    Dim x, i As Long, a(3), s As String
    x = Application.Trim(Split(txt, vbLf))
    For i = UBound(x) To LBound(x) Step -1
        If x(i) Like "####-##-## ##:##:##*" Then
            a(0) = Replace(Left$(x(i), 16), "-", "/")
            a(1) = Trim(Split(Mid$(x(i), 23), "(")(0))
            Exit For
        End If
    Next
    For i = LBound(x) To UBound(x)
        If x(i) Like "####-##-## ##:##:##*" Then
            s = Trim(Split(Mid$(x(i), 23), "(")(0))
            If s <> a(1) Then
                a(2) = Replace(Left$(x(i), 16), "-", "/")
                a(3) = s
                Exit For
            End If
        End If
    Next
    OptionZ = a
End Function

Here are my results in this new Sample. I have 2 scenarios in which the code does not properly evaluate:

In case AB125 - it does not evaluate that the Handler is the only who commented and returns "0", "0" in G and H. I would need to return HandlerZ's most recent comment from 2022-03-16 22:03:16
In case AB126 - it returns Michael's comment as the most recent comment, which I don't need. I would only need HandlerZ's most recent comment from 2022-03-16 16:45

Few time in your result are strange...
change to

Function OptionZ(ByVal Handler As String, ByVal txt As String)
    Dim x, i As Long, a(3) As String, s As String
    Handler = Trim$(Split(Handler, "(")(0))
    x = Application.Trim(Split(txt, vbLf))
    For i = LBound(x) To UBound(x)
        If x(i) Like "####-##-## ##:##:##*" Then
            s = Trim(Split(Mid$(x(i), 23), "(")(0))
            a(0) = Replace(Left$(x(i), 16), "-", "/")
            a(1) = s
            If s = Handler Then
                If a(2) = "" Then
                    a(2) = Replace(Left$(x(i), 16), "-", "/")
                    a(3) = s
                End If
            End If
        End If
    Next
    OptionZ = a
End Function

Your formula is now

=@optionz(J2,AU2)

Remove @ mark.

See sheet2

Here is the way I apply it. Am I doing something wrong?

No use of uploading the workbook without code.

Sorry, here it is again.

Steps which I apply:

1. Apply VBA code from your reply on 03-26-2022, 11:47 AM. This is the final one and the most suitable.

2. I type =OptionZ(J2,AU2) and hit CTRL+SHIFT+ENTER to make it an Array Formula like you also did above (however, previously I was not doing the Array part and everything was working fine).

3. Drag the formula down.

This UDF is made for Office365 or the version with spill functionality.

So, if you enter formula =optionz(J2,AU2) in AW2, it automatically expand the needed columns to AX2, AY2 or AZ2.

If you using earlier version you need to
1) Select AW2:AZ2
2) enter formula
=optionz(J2,AU2)
and confirm with Ctrl + Shift + Enter (array formula entry)

Hello Jindon!

I am back after quite some time with a small extra requirement to the above code

Is it possible to adjust the code to also extract the actual comment that was placed?

Attached my sample showing the desired extra result in yellow.

try change to

Function OptionZ(ByVal Handler As String, ByVal txt As String)
    Dim x, i As Long, a(5) As String, s As String
    Handler = Trim$(Split(Handler, "(")(0))
    x = Application.Trim(Split(txt, vbLf))
    For i = UBound(x) To LBound(x) Step -1
        If x(i) Like "####-##-## ##:##:##*" Then
            s = Trim(Split(Mid$(x(i), 23), "(")(0))
                If a(0) = "" Then
                    a(0) = Replace(Left$(x(i), 16), "-", "/")
                    a(1) = x(i + 1): a(2) = s
                End If
            If s = Handler Then
                a(3) = Replace(Left$(x(i), 16), "-", "/")
                a(4) = x(i + 1): a(5) = s
            End If
        End If
    Next
    OptionZ = a
End Function

Forgot to mention that comments can also include line breaks or can also include multiple lines of text.

I've reattached the new scenario. Result is only partial. Can the rest of the comment be captured too?

Function OptionZ(ByVal Handler As String, ByVal txt As String)
    Dim x, i As Long, a(5) As String, s As String
    Handler = Trim$(Split(Handler, "(")(0))
    x = Application.Trim(Split(txt, vbLf & vbLf))
    For i = UBound(x) To LBound(x) Step -1
        If x(i) Like "####-##-## ##:##:##*" Then
            s = Trim(Split(Mid$(x(i), 23), "(")(0))
                If a(0) = "" Then
                    a(0) = Replace(Left$(x(i), 16), "-", "/")
                    a(1) = Split(x(i), vbLf, 2)(1): a(2) = s
                End If
            If s = Handler Then
                a(3) = Replace(Left$(x(i), 16), "-", "/")
                a(4) = Split(x(i), vbLf, 2)(1): a(5) = s
            End If
        End If
    Next
    OptionZ = a
End Function

Seems that it's working only for text on multiple lines, but not for text with empty line breaks (see Handler's comment)

Attached partial results.

Upload a workbook with all the possible combinations of data and result that you want.

Change to

Function OptionZ(ByVal Handler As String, ByVal txt As String)
    Static RegX As Object
    Dim m As Object, sm As Object, i As Long, a(5) As String
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    Handler = Trim$(Split(Handler, "(")(0))
    With RegX
        .Global = True
        .Pattern = "\d{4}(\-\d{2}){2} \d{2}:\d{2}(.*\n)+?(?=(\d{4}(-\d{2}){2} \d{2}:\d{2}|$))"
        Set m = .Execute(txt)
        .Pattern = "(\d{4}(\-\d{2}){2} \d{2}:\d{2}).+?\- (.+?) \(.+\)\n((.*\n)+)"
        For i = m.Count - 1 To 0 Step -1
            Set sm = .Execute(m(i))(0).submatches
            If a(0) = "" Then
                a(0) = sm(0): a(1) = sm(3): a(2) = sm(2)
            End If
            If sm(2) = Handler Then
                a(3) = sm(0): a(4) = sm(3): a(5) = sm(2)
            End If
        Next
    End With
    OptionZ = a
End Function

You are a God!

Thank you!

Hello Jindon,

Can you help me one more time with another requirement for the attached workbook? Desired result is shown on the right and preferably the second one.

a) purpose is to extract/count all the dates in the chronological order only for 2022 (in which they are listed anyway in each cell)
b) There is no clear standard form. Sometimes "_" is the link and pattern, but sometimes there is no "_" between text and the next date
c) date is always in the dd/mm/yyyy format

Yes, this is a complete new file.

However, the function does not seem to work properly. Uploading a copy of the file with data very close to the actual file and the result.
In my official file I get a lot of "0" and "#SPILL!".

Is the function looking for any string of dd/mm/yyyy and not considering any other delimiters? Because it seems to not work properly.
Also, I now see some variance of also mm/dd/yyyy. Can you adapt the code to also look for this variance?

Change

        .Pattern = "(\d{2})/(\d{2})/(" & myYear & ")"

to

        .Pattern = "(\d{1,2})/(\d{1,2})/(" & myYear & ")"

I am trying =GetDateAndCount(S2,2022) in my official file, but it populates the cells wrongly, as follows:

Attachment 815096

No one can even guess how your "official file"looks like and your attachment in your last post is invalid, so can not open.

Attach your workbook with ALL THE POSSIBLE COMBINATION of the data and the result that you want.

No GUESS game anymore.

Reattaching this example with code applied.

Looking forward.

Now your data is in table...

Need to see your EXACT EXPECTED result.

Reattached. Column B contains the result after applying the code.
Starting Column C are the two desired results separated by border.

(Please note that dates in red are auto-converted by Excel to dd/mm, but they should actually be mm/dd).

Sub test()
    Dim i As Long, ii As Long, x, t As Long, a
    Application.ScreenUpdating = False
    With Sheets("sheet1").ListObjects(1)
        .DataBodyRange.Columns(2).ClearContents
        If .ListColumns.Count > 1 Then
            .ListColumns(2).Range.Resize(, .ListColumns.Count - 1).Delete
        End If
        ReDim a(1 To .ListRows.Count, 1 To 12)
        For i = 1 To .ListRows.Count
            x = GetDateAndCount(.ListRows(i).Range(1), 2022)
            If IsArray(x) Then
                If UBound(x) > .ListColumns.Count - 1 Then
                    t = .ListColumns.Count
                    For ii = 1 To UBound(x) - .ListColumns.Count + 1
                        .ListColumns.Add.Range(1) = "Resut " & t + ii - 1
                    Next
                End If
                For ii = 1 To UBound(x)
                    .ListRows(i).Range(ii + 1) = x(ii)
                Next
                x = GetDateAndCount(.ListRows(i).Range(1), 2022, True)
                For ii = 1 To 12
                    a(i, ii) = x(ii)
                Next
            End If
        Next
        t = .ListColumns.Count
        .ListColumns(2).Range.Resize(, t - 2).NumberFormat = "mm/dd/yyyy"
        For i = 1 To 12
            .ListColumns.Add.Range(1) = Format$(DateSerial(Year(Date), i, 1), "mmmm")
            .ListColumns(t + i).Range.NumberFormat = ""
        Next
        .ListColumns(t + 1).DataBodyRange.Resize(, 12) = a
        .ListColumns(2).Range.Resize(, .ListColumns.Count - 1).HorizontalAlignment = xlCenter
        .Range.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Function GetDateAndCount(ByVal s As String, ByVal myYear As Long, Optional Counts As Boolean = False)
    Static RegX As Object
    Dim a(), b(1 To 12) As String, m As Object, mm As Object, i As Long
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    With RegX
        .Global = True
        .Pattern = "(\d{2})/(\d{2})/(" & myYear & ")"
        If Not .test(s) Then Exit Function
        Set m = .Execute(s)
        ReDim a(1 To m.Count)
        For i = 0 To m.Count - 1
            a(i + 1) = m(i)
            b(Val(m(i).submatches(0))) = Val(b(Val(m(i).submatches(0)))) + 1
        Next
    End With
    If Counts Then
        GetDateAndCount = b
    Else
        GetDateAndCount = a
    End If
End Function

Jindon,

I have changed to: .Pattern = "(\d{1,2})/(\d{1,2})/(" & myYear & ")" and it's perfectly fine. I will further analyze all the 20K lines from official file.

But which line should I change to get the same result only for 2023?

You are a King!

Seems to work properly. I'll get back in case any other discrepancies.

Thank you!

Jindon,

Can this code be adjusted to count & extract only unique values (dates) whenever there are duplicates/triplicates/quadruplicates/etc?

Example and desired result(in yellow) in this attached file.

Replace the function with the below

Function GetDateAndCount(ByVal s As String, ByVal myYear As Long, Optional Counts As Boolean = False)
    Static RegX As Object
    Dim a(), b(1 To 12) As String, n(1) As Long
    Dim m As Object, mm As Object, i As Long, dic As Object
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    Set dic = CreateObject("Scripting.Dictionary")
    With RegX
        .Global = True
        .Pattern = "(\d{1,2})/(\d{1,2})/(" & myYear & ")"
        If Not .test(s) Then Exit Function
        Set m = .Execute(s)
        ReDim a(1 To m.Count)
        For i = 0 To m.Count - 1
            n(0) = Val(m(i).submatches(0))
            If Not dic.exists(m(i).Value) Then
                n(1) = n(1) + 1
                dic(m(i).Value) = Empty: a(n(1)) = m(i): b(n(0)) = Val(b(n(0))) + 1
            End If
        Next
    End With
    ReDim Preserve a(1 To n(1))
    If Counts Then
        GetDateAndCount = b
    Else
        GetDateAndCount = a
    End If
End Function

This new code does not seem to give the desired result.

Attaching the result.

You are missing main sub procedure, i,e, "test".

My mistake

Thank you

Change the pattern to

        .Pattern = "(1[0-2]|[1-9])/(\d{1,2})/(" & myYear & ")"

The conversion seems to work almost fine, except for a few issues which I've highlighted in the attached sample + expected result.

a) "19/01" transforms into "01.09" which is wrong
b) "_19/01/2023text" is taken in consideration but should not be, giving the conditions in above post (there is no "_" in the end after "2023")

Replace the Function with

Function GetDateAndCount(ByVal s As String, ByVal myYear As Long, Optional Counts As Boolean = False)
    Static RegX As Object
    Dim a(), b(1 To 12) As String, n(1) As Long
    Dim m As Object, mm As Object, i As Long, dic As Object
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    Set dic = CreateObject("Scripting.Dictionary")
    With RegX
        .Global = True
        .Pattern = "(1[0-2]|[1-9])/(\d{1,2})/(" & myYear & ")"
        If Not .test(s) Then Exit Function
        Set m = .Execute(s)
        ReDim a(1 To m.Count)
        For i = 0 To m.Count - 1
            n(0) = Val(m(i).submatches(0))
            If Not dic.exists(m(i).Value) Then
                n(1) = n(1) + 1
                dic(m(i).Value) = Empty: a(n(1)) = m(i): b(n(0)) = Val(b(n(0))) + 1
            End If
        Next
    End With
    ReDim Preserve a(1 To n(1))
    If Counts Then
        GetDateAndCount = b
    Else
        GetDateAndCount = a
    End If
End Function

Jindon, I have tried your function but does not seem to change anything.

See attached:

Oops, I posted wrong one.

Function GetDateAndCount(ByVal s As String, ByVal myYear As Long, Optional Counts As Boolean = False)
    Static RegX As Object
    Dim a(), b(1 To 12) As String, n(1) As Long
    Dim m As Object, mm As Object, i As Long, dic As Object
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    Set dic = CreateObject("Scripting.Dictionary")
    With RegX
        .Global = True
        .Pattern = "(^|_)((1[0-2]|0?[1-9])/(\d{1,2})/(" & myYear & "))_"
        If Not .test(s) Then Exit Function
        Set m = .Execute(s)
        ReDim a(1 To m.Count)
        For i = 0 To m.Count - 1
            n(0) = Val(m(i).submatches(2))
            If Not dic.exists(m(i).submatches(1)) Then
                n(1) = n(1) + 1
                dic(m(i).submatches(1)) = Empty: a(n(1)) = m(i).submatches(2): b(n(0)) = Val(b(n(0))) + 1
            End If
        Next
    End With
    ReDim Preserve a(1 To n(1))
    If Counts Then
        GetDateAndCount = b
    Else
        GetDateAndCount = a
    End If
End Function

Still looking strange:

Why do you expect text_19/01/2023_ to exracted as 01.19.2023 ?

Obviously, it is not mm/dd/yyyy format, so the code is not extracting.

If you expect like that, you should explain why.

You are right.

Since there is no technical way in which the code can distinguish between 01.03.2023 as 1st of March or 01.03.2023 as 3rd of January and any variation like this,

Then can the code just capture all dates (that respect the standard format between "_"..."_") and flag under the right Month?

At the moment with:

a) post 71 - code is the closest code to expected result, but it is flagging 19/01/2023 under September, which is wrong and capturing "_19/01/2023text" which is against the standard.
b) post 75 - code is not working at all right

The last line of your expected results is wrong, no Jan.

Function GetDateAndCount(ByVal s As String, ByVal myYear As Long, Optional Counts As Boolean = False)
    Static RegX As Object
    Dim a(), b(1 To 12) As String, n(1) As Long, x, sm As Object
    Dim m As Object, mm As Object, i As Long, dic As Object
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    Set dic = CreateObject("Scripting.Dictionary")
    With RegX
        .Global = True: .MultiLine = True
        .Pattern = "(^|_)((\d{1,2})/(\d{1,2})/(" & myYear & "))(?=(_|$))"
        If Not .test(s) Then Exit Function
        Set m = .Execute(s)
        ReDim a(1 To m.Count)
        For i = 0 To m.Count - 1
            Set sm = m(i).submatches
            x = Array(sm(4), Format$(sm(2), "00"), Format$(sm(3), "00"))
            If x(1) > 12 Then x(1) = x(2): x(2) = sm(2)
            If Not IsDate(Join(x, "/")) Then Exit Function
            n(0) = x(1)
            If Not dic.exists(Join(x, "/")) Then
                n(1) = n(1) + 1
                dic(Join(x, "/")) = Empty: a(n(1)) = Join(x, "/"): b(n(0)) = Val(b(n(0))) + 1
            End If
        Next
    End With
    ReDim Preserve a(1 To n(1))
    If Counts Then
        GetDateAndCount = b
    Else
        GetDateAndCount = a
    End If
End Function

Seems fine now! Let me explore

Include Col.A in the table.
Select B1 - [Table Design] - [Resize Table] change $B$1:$T$3 to $A$1:$T$3

Sub test()
    Dim i As Long, ii As Long, x, t As Long, a
    Const myYear As Long = 2023 '<---
    With Sheets("sheet1").ListObjects(1)
        If .ListColumns.Count > 2 Then
            .ListColumns(3).Range.Resize(, .ListColumns.Count - 2).Delete
        End If
        ReDim a(1 To .ListRows.Count, 1 To 12)
        For i = 1 To .ListRows.Count
            x = GetDateAndCount(.ListRows(i).Range(1), .ListRows(i).Range(2), myYear)
            If IsArray(x) Then
                If UBound(x) > .ListColumns.Count - 2 Then
                    t = .ListColumns.Count
                    For ii = 1 To UBound(x) - .ListColumns.Count + 2
                        .ListColumns.Add.Range(1) = "Resut " & t + ii - 2
                    Next
                End If
                For ii = 1 To UBound(x)
                    .ListRows(i).Range(ii + 2) = x(ii)
                Next
                x = GetDateAndCount(.ListRows(i).Range(1), .ListRows(i).Range(2), myYear, True)
                For ii = 1 To 12
                    a(i, ii) = x(ii)
                Next
            End If
        Next
        t = .ListColumns.Count
        .ListColumns(2).Range.Resize(, t - 1).NumberFormat = "mm/dd/yyyy"
        For i = 1 To 12
            .ListColumns.Add.Range(1) = Format$(DateSerial(Year(Date), i, 1), "mmmm")
            .ListColumns(t + i).Range.NumberFormat = ""
        Next
        .ListColumns(t + 1).DataBodyRange.Resize(, 12) = a
        .ListColumns(2).Range.Resize(, .ListColumns.Count - 1).HorizontalAlignment = xlCenter
        '.Range.Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

Function GetDateAndCount(ByVal Alias As String, ByVal s As String, ByVal myYear As Long, Optional Counts As Boolean = False)
    Static RegX As Object
    Dim a(), b(1 To 12) As String, n(1) As Long, x, sm As Object
    Dim m As Object, mm As Object, i As Long, dic As Object
    If RegX Is Nothing Then Set RegX = CreateObject("VBScript.RegExp")
    Set dic = CreateObject("Scripting.Dictionary")
    With RegX
        .Global = True: .MultiLine = True
        .Pattern = "(^|_)((\d{1,2})/(\d{1,2})/(" & myYear & "))(?=_" & Alias & ")"
        If Not .test(s) Then Exit Function
        Set m = .Execute(s)
        ReDim a(1 To m.Count)
        For i = 0 To m.Count - 1
            Set sm = m(i).submatches
            x = Array(sm(4), Format$(sm(2), "00"), Format$(sm(3), "00"))
            If x(1) > 12 Then x(1) = x(2): x(2) = sm(2)
            If Not IsDate(Join(x, "/")) Then Exit Function
            n(0) = x(1)
            If Not dic.exists(Join(x, "/")) Then
                n(1) = n(1) + 1
                dic(Join(x, "/")) = Empty: a(n(1)) = Join(x, "/"): b(n(0)) = Val(b(n(0))) + 1
            End If
        Next
    End With
    ReDim Preserve a(1 To n(1))
    If Counts Then
        GetDateAndCount = b
    Else
        GetDateAndCount = a
    End If
End Function

change to

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, myYear As Long, myMonth, myDate, myItem, myM, x
    Dim m As Object, sm As Object, n As Long, temp, ub As Long
    With Sheets("settings")
        myYear = Year(Date)
        myM = [text(column(a:l)*29,"mmm")]
        myMonth = Application.Match(Left$(.[g8], 3), myM, 0)
        myItem = Filter(.[transpose(if(g10:g17<>"",g10:g17))], False, 0)
    End With
    With Sheets.Add(Sheets(1))
        .Cells.Clear
        Sheets("result").ListObjects(1).ListColumns(1).Range.Copy .Cells(1)
        .Columns(1).ColumnWidth = Sheets("result").ListObjects(1).ListColumns(1).Range.ColumnWidth
        a = .Range("a1").CurrentRegion.Value
        With CreateObject("VBScript.RegExp")
            .Global = True: .MultiLine = True
            .Pattern = "(^|_)(\d{1,2})/(\d{1,2})/(" & myYear & ")(_ALIAS\d+)?_?([^_]+)(?=([_ ]|$))"
            For i = 2 To UBound(a, 1)
                n = 1
                For Each m In .Execute(a(i, 1))
                    Set sm = m.submatches
                    x = Array(myYear, sm(1), sm(2))
                    If (sm(1) > 12) * (sm(2) < 13) Then temp = x(1): x(1) = x(2): x(2) = temp
                    myDate = DateSerial(x(0), x(1), x(2))
                    If Month(myDate) = myMonth Then
                        n = n + 1
                        If n > UBound(a, 2) Then ReDim Preserve a(1 To UBound(a, 1), 1 To n)
                        a(i, n) = Array(myDate, sm(5))
                    End If
                Next
            Next
            ub = UBound(a, 2)
            ReDim Preserve a(1 To UBound(a, 1), 1 To ub + UBound(myItem) + 1)
            For i = 2 To UBound(a, 1)
                For ii = 2 To ub
                    If IsArray(a(i, ii)) Then
                        For iii = 0 To UBound(myItem)
                            If a(i, ii)(1) Like myItem(iii) & "*" Then
                                a(i, ub + iii + 1) = a(i, ub + iii + 1) + 1: Exit For
                            End If
                        Next
                        a(i, ii) = a(i, ii)(0)
                    End If
                Next
            Next
        End With
        With .[a1].CurrentRegion.Resize(, UBound(a, 2))
            .Value = a
            With .Columns("b").Resize(, .Columns.Count - UBound(myItem) - 2)
                .NumberFormatLocal = "mm/dd/yyyy"
                .Cells(1) = myM(myMonth)
                .Rows(1).HorizontalAlignment = xlCenterAcrossSelection
            End With
            With .Columns(ub + 1).Resize(, UBound(myItem) + 1)
                .Rows(1) = myItem
                .HorizontalAlignment = xlCenter
            End With
            .Borders.Weight = 2
            .Offset(, 1).Columns.AutoFit
        End With
    End With
End Sub

Originally Posted by jindon

change to

Sub test()
    Dim a, i As Long, ii As Long, iii As Long, myYear As Long, myMonth, myDate, myItem, myM, x
    Dim m As Object, sm As Object, n As Long, temp, ub As Long
    With Sheets("settings")
        myYear = Year(Date)
        myM = [text(column(a:l)*29,"mmm")]
        myMonth = Application.Match(Left$(.[g8], 3), myM, 0)
        myItem = Filter(.[transpose(if(g10:g17<>"",g10:g17))], False, 0)
    End With
    With Sheets.Add(Sheets(1))
        .Cells.Clear
        Sheets("result").ListObjects(1).ListColumns(1).Range.Copy .Cells(1)
        .Columns(1).ColumnWidth = Sheets("result").ListObjects(1).ListColumns(1).Range.ColumnWidth
        a = .Range("a1").CurrentRegion.Value
        With CreateObject("VBScript.RegExp")
            .Global = True: .MultiLine = True
            .Pattern = "(^|_)(\d{1,2})/(\d{1,2})/(" & myYear & ")(_ALIAS\d+)?_?([^_]+)(?=([_ ]|$))"
            For i = 2 To UBound(a, 1)
                n = 1
                For Each m In .Execute(a(i, 1))
                    Set sm = m.submatches
                    x = Array(myYear, sm(1), sm(2))
                    If (sm(1) > 12) * (sm(2) < 13) Then temp = x(1): x(1) = x(2): x(2) = temp
                    myDate = DateSerial(x(0), x(1), x(2))
                    If Month(myDate) = myMonth Then
                        n = n + 1
                        If n > UBound(a, 2) Then ReDim Preserve a(1 To UBound(a, 1), 1 To n)
                        a(i, n) = Array(myDate, sm(5))
                    End If
                Next
            Next
            ub = UBound(a, 2)
            ReDim Preserve a(1 To UBound(a, 1), 1 To ub + UBound(myItem) + 1)
            For i = 2 To UBound(a, 1)
                For ii = 2 To ub
                    If IsArray(a(i, ii)) Then
                        For iii = 0 To UBound(myItem)
                            If a(i, ii)(1) Like myItem(iii) & "*" Then
                                a(i, ub + iii + 1) = a(i, ub + iii + 1) + 1: Exit For
                            End If
                        Next
                        a(i, ii) = a(i, ii)(0)
                    End If
                Next
            Next
        End With
        With .[a1].CurrentRegion.Resize(, UBound(a, 2))
            .Value = a
            With .Columns("b").Resize(, .Columns.Count - UBound(myItem) - 2)
                .NumberFormatLocal = "mm/dd/yyyy"
                .Cells(1) = myM(myMonth)
                .Rows(1).HorizontalAlignment = xlCenterAcrossSelection
            End With
            With .Columns(ub + 1).Resize(, UBound(myItem) + 1)
                .Rows(1) = myItem
                .HorizontalAlignment = xlCenter
            End With
            .Borders.Weight = 2
            .Offset(, 1).Columns.AutoFit
        End With
    End With
End Sub

Hi Jindon,

Can you check the outcome? I see the code generated the result in a new sheet ("Your Result"), but it is not counting the text after I change it in "Settings".

I need to be able to write whatever text in "Settings" and the code needs to count it.

I have attached a sample as close as possible to my actual data and changed the free text in "Settings". I've also created a sheet with "My Desired Result".

Thank you!

1)
Please don't quote whole posts -- it's just clutter. If you are responding to a post out of sequence, limit quoted content to a few relevant lines that makes clear to whom and what you are responding

2) Before we go with the workbook you last attached, you need to tell me if the code I posted in #86 is working or not with the workbook you attached in #85.
If not, you need to tell me how it was not working. This is the first step to continue.

3) What is your intention to change data/ data layouts time after time?
If you think you can change/adjust the given codes please do so.
If not, you should upload a workbook which is closesst to your actual data set contains all the possible combinstions of the data at first to save time for both ends.

Otherwise mark this thread as "Solved" and open a new thread for the last one.

Ok, so this was making the difference: "the longer string should appear above the shorter one"

You're a star!

Seems to work. Let me further test.

Let me clear;
Dates are OK.

Problem is finding "Free text to look for:" within a string.

Look at the data you posted in #85.
in A4

01/28/2024_ALIAS2_FREE TEXT FREE TEXT1_TEXT_19/01/2024FREE TEXT2 23/914_
12/23/2022_ALIAS1_text text text text text text_text text text text_

No underscore after the date (19/01/2024FREE TEXT2).
The code is written to match this case too.

That's why I said the logic to find those string is NONE.

So, you now must give me CLEAR logic to find those word from the string.

But in my latest post (#92) the problem is with dates and text (in case of duplicate dates and duplicate texts)

Can you just adjust the code from #92 to count & extract duplicates only once? (you managed to apply this rule before in older posts).

I am attaching this picture for better clarification. The result in the picture is with code from post #90(same #92).

Red = not ok
Green arrows = what should be the change = duplicates to be considered only once
Green checkmarks = what is already ok and no need for change

You are not answering to my question.

I said

So, you now must give me CLEAR logic to find those word from the string.

And I've never heard of DULPICATES.

This is the last.

Upload a workbook that shows all the possible variation of the data and the result that you want.
Tell clear logic to match the "Free text to look for:".

Otherwise, just wasting time...

Ok, attaching workbook with all the rules and instructions.

I hope this helps you better, but let me know in case there are still doubts.

Many thanks again

For the data provided.

Sub test()
    Dim a, b, e, s, txt As String, myYear As Long, myMonth, myDate, myItem, myM, n As Long
    Dim i As Long, ii As Long, iii As Long, m As Object, sm As Object, x
    With Sheets("settings")
        myYear = Year(Date): myM = [text(column(a:l)*29,"mmm")]
        myMonth = Application.Match(Left$(.[g8], 3), myM, 0)
        If myMonth < 10 Then s = "0?" & myMonth Else s = myMonth
        myItem = Filter(.[transpose(if(g10:g19<>"",g10:g19))], False, 0)
    End With
    If Not [isref(result!a1)] Then Sheets.Add(, Sheets("mydata")).Name = "Result"
    With Sheets("result")
        .Cells.Clear
        Sheets("mydata").ListObjects(1).ListColumns(1).Range.Copy .Cells(1)
        If .ListObjects.Count Then .ListObjects(1).Unlist
        .Columns(1).ColumnWidth = Sheets("mydata").ListObjects(1).ListColumns(1).Range.ColumnWidth
        a = .Range("a1").CurrentRegion.Value
        With CreateObject("VBScript.RegExp")
            .Global = True: .MultiLine = True
            .Pattern = "(^|_)((1[3-9]|2[0-9]|3[01])/" & s & "|" & s & _
                "/(\d{1,2}))/\d{4}_.*_([^_ ]+)[^_]*_(?=(\d{1,2}/\d{1,2}/\d{4}|$))"
            For i = 2 To UBound(a, 1)
                txt = a(i, 1): Set a(i, 1) = CreateObject("Scripting.Dictionary")
                For Each m In .Execute(txt)
                    Set sm = m.submatches
                    myDate = DateSerial(myYear, myMonth, sm(2) + sm(3))
                    If Not a(i, 1).exists(myDate) Then
                        Set a(i, 1)(myDate) = CreateObject("Scripting.Dictionary")
                    End If
                    If Not a(i, 1)(myDate).exists(sm(4)) Then a(i, 1)(myDate)(sm(4)) = 1
                    If n < a(i, 1).Count Then n = a(i, 1).Count
                Next
            Next
            ReDim b(1 To UBound(a, 1), 1 To n + UBound(myItem) + 1)
            For i = 2 To UBound(a, 1)
                For ii = 0 To a(i, 1).Count - 1
                    s = a(i, 1).keys()(ii)
                    b(i, ii + 1) = s
                    For Each e In a(i, 1)(s).keys
                        x = Application.Match(e, myItem, 0)
                        If IsNumeric(x) Then b(i, n + x) = b(i, n + x) + 1
                    Next
                Next
            Next
        End With
        With .[a1].CurrentRegion.Columns(2).Resize(, UBound(b, 2))
            .Value = b
            With .Columns(1).Resize(, n)
                .NumberFormatLocal = "mm/dd/yyyy"
                .Cells(1) = myM(myMonth)
                .Rows(1).HorizontalAlignment = xlCenterAcrossSelection
            End With
            With .Columns(n + 1).Resize(, UBound(myItem) + 1)
                .Rows(1) = myItem
                .HorizontalAlignment = xlCenter
            End With
            .Borders.Weight = 2
            .Rows.AutoFit: .Columns.AutoFit
        End With
    End With
End Sub