Consulting

Results 1 to 4 of 4

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

  1. #1
    VBAX Tutor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    231
    Location

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

    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
    Attached Files Attached Files

  2. #2
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,344
    Location
    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?
    ____________________________________________
    Nihil simul inventum est et perfectum

    Abusus non tollit usum

    Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
    James Thurber

  3. #3
    VBAX Tutor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    231
    Location
    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!
    Last edited by anish.ms; 12-02-2021 at 07:35 AM.

  4. #4
    VBAX Tutor
    Joined
    Nov 2020
    Location
    Cochin, Kerala
    Posts
    231
    Location
    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
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •