Help : Maxifs with criteria of any part of the cell value separated with commas

[anish.ms]

Hi Experts,

I have attached a sample file where the sheet "Follow-up Visit" contains the details of doctor consultations within the free follow-up period and sheet "Paid Visit" contains all the paid consultation details. I have the code to find previous paid visit date in column "N" in sheet "Follow-up Visit" if the patient id matches with the doctor or specialty selected in column "N1".
I have a situation where I seek your help to find the paid visit date only if any of the diagnosis code in column "G" matches. Dianosis codes are separated with commas.

For example in case of patient ID 45419616, the diagnosis code in follow-up visit is K29.70, K58.9 whereas the code in sheet paid visit is R10.84, K21.9 - in this case I have look for the next date as none of the codes are matching

I assume this can be done by splitting the values into an array, but I'm not sure how this can be incorporated in the existing codes
Hope I was able explain the situation

Thanks in advance for your help!

Option Explicit
Sub This_Way()
    Dim t0     As Date
    Dim ColMatch As Integer, i As Long, b_max As Long, a_max As Long, RDate As Long
    Dim PtId   As Range, BillDate As Range, CriteriaCol As Range
    Dim chk_PtId As Variant, chk_BillDate As Variant, chk_CriteriaCol As Variant


    On Error Resume Next
    t0 = Now
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    With Sheets("Follow-up Visit")
        ColMatch = WorksheetFunction.Match(.Range("N1"), .Range("A2:F2"), 0)
    End With
    With Sheets("Paid Visit")
        b_max = .UsedRange.Rows.Count
        Set PtId = .Range("A2:A" & b_max)
        Set BillDate = .Range("C2:C" & b_max)
        Set CriteriaCol = .Range(.Cells(2, ColMatch), .Cells(b_max, ColMatch))
    End With
    
    With Sheets("Follow-up Visit")
        a_max = .UsedRange.Rows.Count
        If a_max > 2 Then .Range("N3:O" & a_max).ClearContents
        For i = 3 To a_max
            chk_PtId = .Cells(i, "A")
            chk_BillDate = "<=" & CLng(.Cells(i, "C"))
            chk_CriteriaCol = .Cells(i, ColMatch)
            RDate = WorksheetFunction.MaxIfs(BillDate, PtId, chk_PtId, BillDate, chk_BillDate, CriteriaCol, chk_CriteriaCol)
            If RDate > 0 Then
                .Cells(i, "N") = RDate
                .Cells(i, "O") = .Cells(i, "C") - RDate
            End If
            DoEvents
            Application.StatusBar = "Finding Previous Paid Visit Date : " & Format(i / a_max, "0.00%")
        Next i
    End With
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .StatusBar = False
    End With
    MsgBox Format(Now - t0, "hh:mm:ss"), vbInformation, "Completed"
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub