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! :bow:

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