anish.ms
12-01-2021, 08:22 PM
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
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