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

[Bob Phillips]

More explanation would help. For instance, where do those codes come from, what are you matching against? Does the code you showed have any relevance to this problem?

[anish.ms]

Hi Bob,

Thanks for your time!

Currently my VBA code is finding the immediate previous paid bill date from sheet2 (refers to paid consultation bills) against each patient id in sheet1 (refers to free follow-up consultation bills) based on the criteria selected (Doctor/Speciality).
As per the rules (varies based on locations), if a patient consults a doctor/specialty (paid) for any illness and again if the patient consults within 7days for the same illness, the second consultation cannot be billed. This is what I'm checking using the code to identify any missing billing (more than 7 days gap b/w the dates). I want to modify the VBA code to also check the diagnosis codes in column G. But the problem is there are multiple diagnosis codes against each consultation.

In the below instance, my VBA code is taking the previous paid bill date as 28-May-2020. Because currently it is not checking the diagnosis codes

		Patient No.	Visit / Bill Date	Doctor	Speciality	Item	Diagnosis	Gross Amount	Discount Amount	Net Amount
Sheet 1	Follow-up Visit	45419616	05-Jun-2020	Doctor 14	EMERGENCY MEDICINE	Follow-up Consultation	K29.70, K58.9			-
Sheet 2	Paid Visit	45419616	28-May-2020	Doctor 24	EMERGENCY MEDICINE	Paid Consultation	R10.84 , K21.9			206

In the below instance, one diagnosis code is matching (G43.001), hence the date 13-Jun-2020 can be considered

		Patient No.		Visit / Bill Date	Doctor	Speciality	Item	Diagnosis	Gross Amount	Discount Amount	Net Amount
Sheet 1	Follow-up Visit	75856968		25-Jun-2020	Doctor 19	NEUROLOGY	Follow-up Consultation	G43.001, M54.81			-
Sheet 2	Paid Visit	75856968		13-Jun-2020	Doctor 35	NEUROLOGY	Paid Consultation	G43.001			311

Hope I was able explain better

Thanks in advance for your help!

[anish.ms]

I have done it, It looks little lengthy
Any suggestions for the improvement please

Option Explicit
Public FU_Visit     As Worksheet
Public PD_Visit     As Worksheet
Public RowLast_FUV     As Long
Public RowLast_PDV     As Long


Sub Init()
    Set FU_Visit = Sheets("Follow-up Visit")
    Set PD_Visit = Sheets("Paid Visit")
    RowLast_FUV = FU_Visit.UsedRange.Rows.Count
    RowLast_PDV = PD_Visit.UsedRange.Rows.Count
End Sub


Sub CkeckDates()
    Dim pt     As Range, ptRange As Range
    Dim aryFUPtSplty() As String
    Dim aryPDPtSplty() As String
    Dim combined      As String
    Dim i      As Long, j As Long, n As Long, k As Long, c As Long
    Dim DiagArr As Variant


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Init
    FU_Visit.Range("N2:O" & RowLast_FUV).ClearContents
    
    ReDim aryFUPtSplty(2 To RowLast_FUV)
    ReDim aryPDPtSplty(2 To RowLast_PDV)
    
    Set ptRange = FU_Visit.Range("A2:A" & RowLast_FUV)
    
    For Each pt In ptRange
        combined = FU_Visit.Cells(pt.Row, "A") & FU_Visit.Cells(pt.Row, "E")
        aryFUPtSplty(pt.Row) = combined
    Next pt
    
    Set ptRange = PD_Visit.Range("A2:A" & RowLast_PDV)
    
    For Each pt In ptRange
        combined = PD_Visit.Cells(pt.Row, "A") & PD_Visit.Cells(pt.Row, "E")
        aryPDPtSplty(pt.Row) = combined
    Next pt
    
    For i = LBound(aryFUPtSplty) To UBound(aryFUPtSplty)
        For j = LBound(aryPDPtSplty) To UBound(aryPDPtSplty)
            If aryFUPtSplty(i) = aryPDPtSplty(j) Then
                c = 0
                If CLng(PD_Visit.Cells(j, "C")) <= CLng(FU_Visit.Cells(i, "C")) Then
                    If IsEmpty(FU_Visit.Cells(i, "N")) Then
                        
                        DiagArr = Split(Trim(FU_Visit.Cells(i, "G")), ",")
                        For n = 0 To UBound(DiagArr)
                            k = InStr(1, Trim(PD_Visit.Cells(j, "G")), DiagArr(n))
                            If k > 0 Then
                                c = c + 1
                                FU_Visit.Cells(i, "N") = PD_Visit.Cells(j, "C")
                                FU_Visit.Cells(i, "O") = c
                            End If
                        Next n
                        
                    ElseIf CLng(PD_Visit.Cells(j, "C")) >= CLng(FU_Visit.Cells(i, "N")) Then
                        
                        DiagArr = Split(Trim(FU_Visit.Cells(i, "G")), ",")
                        For n = 0 To UBound(DiagArr)
                            k = InStr(1, Trim(PD_Visit.Cells(j, "G")), DiagArr(n))
                            If k > 0 Then
                                c = c + 1
                                FU_Visit.Cells(i, "N") = PD_Visit.Cells(j, "C")
                                FU_Visit.Cells(i, "O") = c
                            End If
                        Next n
                    End If
                End If
            End If
        Next j
        DoEvents
        Application.StatusBar = "Processing : " & Format(i / UBound(aryFUPtSplty), "0%")
    Next i
    Erase aryFUPtSplty
    Erase aryPDPtSplty
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .StatusBar = False
    End With
End Sub