When a test is cancelled in the system it appears as a charge and then a credit with the same date and time.
The billing team does not want to see these, as they have to charge for a test and them immediately credit a test, and it’s a hassle. So we clean them up before submitting.
Often a test gets ordered, cancelled, and then re-ordered, so it is important to make sure the code doesn’t delete the re-ordered test:
(In this case they ordered the test then realized it was already ordered so they cancelled the new order).
There are also simple credited tests, for whatever reason we cannot charge for them. The billing team wants’ these tests to be highlighted and the word CREDIT typed in red in the last column beside it.
Also on these credited tests the quantity is a positive 1. For whatever reason, the billing team wants this changed to a negative 1.
This will be the most complicated macro so far, and since we may be fiddling with multiple rows at a time, we cannot afford to use a janky while loop that changes it’s index on the fly like our previous macros. Instead we will make a list of the rows that need to be deleted/marked, and double check them before taking action.
First thing I will do is add a UDT (User-defined-type) to the module. This will make the code much easier to understand and work with because we will be doing a lot of scanning and checking.
How to add a UDT to an Excel macro:
Private Type DELETEDTESTS
strPatientName As String
dtDateTime As Date
strTestName As String
intRow As Integer
End Type
Dim TestsToDelete() As DELETEDTESTS
Dim TestsToFlag() As DELETEDTESTS
You have to put UDT’s in a module, at the top of the module:
I named the function HandleCredits. It uses 2 other functions called "SeekEvilTwin" and "IsInTestsToBeDeletedAlready". You have to read the comments in the code to understand why these are so interestingly named.
Advanced Excel macro example with arrays, UDT’s, and functions:
Sub HandleCredits()
'This macro will seek credits and take the appropriate action to handle them.
'Cancelled tests will cancel each other out and be deleted.
'Single credited tests will be highlighted and have quantity changed to a negative.
'For this macro we could use a nested loop, but for clarity we will put the second
'loop inside a separate function.
'To record which row, patient, and time need to be deleted we will use an array and
'a UDT or user-defined-type. A separate array will handle simple credits.
'The UDT is defined at the top of the macro module, along with the UDT arrays:
'TestsToDelete() and TestsToFlag()
'Loop through and analyze entire report
intFinalRow = Range("A65536").End(xlUp).Row
Dim intX As Integer 'Index to keep track in loop.
ReDim TestsToDelete(0 To 0) 'This prepares the array and makes one blank spot ready.
ReDim TestsToFlag(0 To 0)
'This is a For Next loop and will repeat a fixed number of times unless 'Exit For' is read.
For intX = 2 To intFinalRow 'For each row in the report...
'We only care about credits so if the charge is positive we skip it.
If Cells(intX, 5).Value < 0 Then 'If negative value then check.
'Ok now we need to figure out if it's a credit or a cancel. How?
'Cancelled tests have an 'Evil Twin', a test with same Patient Name, Test, and DATE/TIME, but a positive charge. (why is positive evil? Because we can't overcharge!)
'Credited tests may have a test with only the same Name and Test, but the DATE/TIME will be different. More like an 'Evil Cousin". We don't care about them.
'I will make a function to search for an evil twin, if none is found, the test will be added to the TestsToFlag array.
Dim EvilTwinTest As DELETEDTESTS 'Stores evil twin info if found.
Dim CreditedTest As DELETEDTESTS 'We can use the UDT to store test info, and pass it to our evil twin seeking function.
With CreditedTest
.strPatientName = Cells(intX, 1).Value
.strTestName = Cells(intX, 3).Value
.dtDateTime = Cells(intX, 8).Value
.intRow = intX
End With
EvilTwinTest = SeekEvilTwin(CreditedTest) 'Seek it's twin!
If EvilTwinTest.intRow > 0 Then 'This is a cancel
'A test with same Patient name, date/time, but positive charge was found. This is a cancelled test.
'Now we add this test and it's twin to the TestsToDelete array, to be deleted later.
If UBound(TestsToDelete) = 0 Then 'Initially we set it to 0, so our blank spot is ready.
TestsToDelete(0) = CreditedTest
ReDim Preserve TestsToDelete(0 To 1) 'Have to make a spot for it's evil twin while preserving first info
TestsToDelete(1) = EvilTwinTest
Else 'Increase array size and populate accordingly.
ReDim Preserve TestsToDelete(LBound(TestsToDelete) To UBound(TestsToDelete) + 1)
TestsToDelete(UBound(TestsToDelete)) = CreditedTest
ReDim Preserve TestsToDelete(LBound(TestsToDelete) To UBound(TestsToDelete) + 1)
TestsToDelete(UBound(TestsToDelete)) = EvilTwinTest
End If 'End check for beginning of array.
Else 'nothing indicates not found, so this is a credit.
'Add test to TestsToFlag array
If TestsToFlag(UBound(TestsToFlag)).strPatientName = "" Then 'Initially we set it to 0, so our blank spot is ready.
TestsToFlag(0) = CreditedTest
Else 'Increase array size and populate accordingly.
ReDim Preserve TestsToFlag(LBound(TestsToFlag) To UBound(TestsToFlag) + 1)
TestsToFlag(UBound(TestsToFlag)) = CreditedTest
End If 'End check for beginning of array.
End If 'End check for evil twin (cancelled test)
Else 'Else skip to next.
End If 'End check neg val if.
Next intX 'On to the next record
'The loop has scanned the sheet and given us two arrays TestsToDelete and TestsToFlag.
'Handling TestsToDelete may alter the row numbers of the data on the sheet, so we will start with TestsToFlag
Dim intZ As Integer
For intZ = LBound(TestsToFlag) To UBound(TestsToFlag)
With TestsToFlag(intZ)
'Remember, there will be at least one slot in TestsToFlag even if none matched, so we check for that:
If .intRow > 0 And .strPatientName <> "" Then 'Something is there.
'Add the credit flag and highlighting.
Cells(.intRow, 9).Interior.Color = vbYellow
Cells(.intRow, 9).Font.Color = vbRed
Cells(.intRow, 9).Value = "CREDIT"
'Remember we need to change that quantity value in other column.
Cells(.intRow, 6).Value = -1 'Change value from 1 to -1.
End If 'End check for blank.
End With
Next intZ
'All done with TestsToFlag, we should delete it to make sure it doesn't end up getting used on another worksheet somehow.
Erase TestsToFlag
'Now we can handle TestsToDelete. We have to be careful, if we delete a row at the top of the sheet, all the indexes
'of the other rows will be off by one and so on.
'Two ways we might manage this: 1-Instead of deleting rows, just blank them out, then use the DeleteZero macro we made earlier to clean up.
'2-Instead on starting at the top we can start at the bottom and work our way up.
'The problem with just working back up is that the rows in TestsToDelete might not be in perfectly sequential order.
'So the safest bet is to just blank out the unwanted rows and delete all blank rows afterward.
'Still just for the examples sake I will loop through the array in reverse so you can see how that is done.
Dim intW As Integer
For intW = UBound(TestsToDelete) To LBound(TestsToDelete) Step -1
With TestsToDelete(intW)
If .intRow > 0 And .strPatientName <> "" Then 'Something is there.
'We know what row to delete so we could just do that here, but since this is a medical/financial macro, we'll add an extra check
'to be sure we're deleting the right thing.
'It is unsafe to do a direct comparison of DATE/TIME's. So I use CDate to convert the raw cell value to a date/time.
If Cells(.intRow, 1).Value = .strPatientName And Cells(.intRow, 3).Value = .strTestName And CDate(Cells(.intRow, 8).Value) = .dtDateTime Then
'Everything matches up, delete it.
Rows(.intRow).Clear
Else 'Uh-oh something is wrong
'Alert the user and abort before you mess anything else up.
MsgBox "Macro tried to delete wrong row? Aborting.", vbCritical, "Macro error in HandleCredits"
Exit Sub
End If 'End verify row information
End If 'end check for blank.
End With '(TestsToDelete)
Next intW 'Next
'All done, erase TestsToDelete
Erase TestsToDelete
'Delete blank rows
DeleteZero
End Sub
Function SeekEvilTwin(CreditedTest As DELETEDTESTS) As DELETEDTESTS
'This will loop through all the rows again seeking the twin.
'If the user has run the macros in order the sort has already been performed,
'and the original charge will be above the credited row we are working on.
'But since we can't be sure the sort has been done we check all rows.
intFinalRow = Range("A65536").End(xlUp).Row
Dim intY As Integer 'Index to keep track in loop.
'This is a For Next loop and will repeat a fixed number of times unless 'Exit For' is read.
For intY = 2 To intFinalRow 'For each row in the report...
If Cells(intY, 5).Value > 0 Then 'Looking for the twin with positive charge. (this will also keep us from comparing the same line to itself)
'Compare the current row info to what we were given.
Dim CurrentTest As DELETEDTESTS
With CurrentTest
.strPatientName = Cells(intY, 1).Value
.strTestName = Cells(intY, 3).Value
.dtDateTime = Cells(intY, 8).Value
.intRow = intY
End With
'Can we compare the udt directly? A: No, because row will be different.
With CurrentTest
If .strPatientName = CreditedTest.strPatientName And .strTestName = CreditedTest.strTestName Then
'Aha! They match, but is it an evil twin or an evil cousin?
If .dtDateTime = CreditedTest.dtDateTime Then 'Evil twin it is
'We are still not done checking, multiple charge/credit pairs with the same date and time
'can exist, so we must make sure this row has not already been matched and saved previously
'LOOP THROUGH CURRENT TESTSTODELETE AND SEARCH FOR MATCH
If IsInTestsToDeleteAlready(CurrentTest) = True Then
'This row has already matched to another, continue loop search.
Else 'It is a match
'So to conclude this function, we return the current test
SeekEvilTwin = CurrentTest
Exit Function 'A chargeback can appear only once, search is over
End If
Else 'The date/time does not match, it must have been a simple credit for some other reason.
'Just because we found a same-named test and patient doesn't mean we can stop here.
End If 'End compare date/time
Else 'The name & test did not match, do nothing and continue.
End If 'End compare name and test.
End With '(CurrentTest)
Else 'The row contained a negative credit.
End If 'End check charge amount.
Next intY 'Next row
'At the end of the loop all rows have been checked. We leave the default value of 0 to indicate no twin found anywhere.
With SeekEvilTwin
.dtDateTime = 0
.intRow = 0
.strPatientName = ""
.strTestName = ""
End With
End Function
Function IsInTestsToDeleteAlready(CurrentTest As DELETEDTESTS) As Boolean
If UBound(TestsToDelete) <= 0 Then 'Just initialized and may be empty.
If TestsToDelete(0).strPatientName = "" Then 'blank, empty
IsInTestsToDeleteAlready = False
Exit Function
Else 'TestsToDelete has one item, continue
End If 'end check blank TestsToDelete
Else 'TestsToDelete is not empty
End If 'End check TestsToDelete empty.
Dim intX As Integer
For intX = LBound(TestsToDelete) To UBound(TestsToDelete)
With TestsToDelete(intX)
If .dtDateTime = CurrentTest.dtDateTime And .intRow = CurrentTest.intRow And .strPatientName = CurrentTest.strPatientName And .strTestName = CurrentTest.strTestName Then
IsInTestsToDeleteAlready = True
Exit Function
Else 'Not same, keep looking
End If 'end compare if.
End With
Next intX
IsInTestsToDeleteAlready = False 'If it got through the whole loop then there was no match.
End Function
Wow that’s a lot of code! Told you it would be complicated, but this is a great real-world example of the power of Excel vba.
Improvements are possible. For one thing, this macro makes rows of data disappear, it would be better to show the user what had been deleted. We could copy the deleted data to another worksheet or pop up a messagebox. Can you think of any other improvements?
In the final tutorial, I will show you how to make a custom drop-down menu to run the macros without having to pull up the macro dialog.
Next Tutorial: Adding custom Macro buttons to your Excel toolbar
Excel Macro Tutorial 1 – Open a text file
Excel Macro Tutorial 2 – Formatting the Columns and Column headers
Excel Macro Tutorial 3 – Remove header rows and delete junk loop
Excel Macro Tutorial 4 – Delete non-chargeable tests and sort
Excel Macro Tutorial 5 – Delete cancelled tests, flag credited tests
Excel Macro Tutorial 6 – Add macro buttons to your toolbar
