Macro to delete rows with matching Credits and Debits

T

Tasha

I have posted on this website once before about a problem I am having trying
to create a macro that will delete accounts with credits and debits of the
same amount. I never could get the macros to work that I was given to try,
so since this has been a while ago, thought I'd try again. Going to try to
make it as simple as I can. I have a report in Excel, contains the following
information:
A B C D E F G
H I
Room#/PatientNo/Patient Name/CNSDay/#Days/F_C/HSV/QTY/AMT

In these columns is patient information that is updated daily, and changes
daily. It is showing patients that are charged room charges, and sometimes
the room charges are wrong, so are credited back to that patient account, and
sometimes the correct one is added on. I have been manually going in and
deleting the credits and debits, and need to find a way to do this with a
macro. Below is shown an example of data in the report, and which ones would
be deleted. Sorry if this is a little long, but need to show different
scenarios. The asterisks to the side show which rows would be deleted. I
sort by PatientNo, CNSDay and AMT, if there is a debit and credit for the
same patient, same CNSDay and same amount, it gets deleted. Hope this makes
sense, I need help badly, this is taking so much time to do it manually every
day since this report can contain as many as 1000 or more patient listings at
a time. Thanks in advance for your assistance!!!

A B C D E F G
H I
Room#/PatientNo/Patient Name/CNSDay/#Days/F_C/HSV/QTY/ AMT
1502 2000000 John Doe 1 15 M MIP 1
1,044.74
1502 2000000 John Doe 2 15 M MIP (1)
(1,044.74) *
1502 2000000 John Doe 2 15 M MIP 1
1,023.75
1502 2000000 John Doe 2 15 M MIP 1
1,044.74 *
1502 2000000 John Doe 3 15 M MIP (1)
(1,044.74) *
1502 2000000 John Doe 3 15 M MIP 1
1,023.75
1502 2000000 John Doe 3 15 M MIP 1
1,044.74 *
1621 2000001 Joe Schmoe 9 13 N SWG (1)
(1,023.75) *
1621 2000001 Joe Schmoe 9 13 N SWG 1 457.07
1621 2000001 Joe Schmoe 9 13 N MIP 1
1,023.75 *
1751 2000002 Sandy Box 7 7 MG SWG (1)
(1,371.22) *
1751 2000002 Sandy Box 7 7 MG ICU 1
1,371.22 *
1760 2000003 Anne Ride 1 4 H MIP 1
1,023.75
1760 2000003 Anne Ride 2 4 H MIP 1
1,023.75
1071 2000004 Ed Crumply 7 1 F SIP (1)
(708.93) *
1071 2000004 Ed Crumply 7 1 F SIP 1
708.93 *
 
J

Joel

This code should work. I added a new column J to sort by absolute amount of
AMT. Then I check if the present row and next row match using patient name,
CNSDAY and AMT (column I) = -1 * next row.

Sub DeleteDuplicates()
'
' Macro1 Macro
' Macro recorded 1/29/2008 by Joel Warburg
'

'
Lastrow = Range("A" & Rows.Count).End(xlUp).Row
'add auxilarry column with absolute amount
For RowCount = 2 To Lastrow
If Range("I" & RowCount) > 0 Then
Range("J" & RowCount) = Range("I" & RowCount)
Else
Range("J" & RowCount) = -1 * Range("I" & RowCount)
End If
Next RowCount
'sort data by Patient - CNSDay - Absolute Amount
Range("A2:J" & Lastrow).Sort _
Key1:=Range("B2"), _
MatchCase:=False, _
Key2:=Range("D2"), _
MatchCase:=False, _
Key3:=Range("J2"), _
MatchCase:=False

'delete duplicates
RowCount = 2
Do While Range("A" & RowCount) <> ""
If Range("B" & RowCount) = Range("B" & (RowCount + 1)) And _
Range("D" & RowCount) = Range("D" & (RowCount + 1)) And _
Range("I" & RowCount) = -1 * Range("I" & (RowCount + 1)) Then

Rows(RowCount).Delete

Else
RowCount = RowCount + 1
End If
Loop

'remove auxillary column J
Columns("J:J").Delete

End Sub
 
T

Tasha

Thanks so much Joel for your reply. I thought it had worked, as I scrolled
down through my report, until I got halfway down then it stopped working and
the credits/debits are still on the bottom half. It seems to have stopped at
an account that doesn't have a room number, which some of them sometimes
won't because they are observation patients and not actually admitted to a
room. Not sure why it stopped though if you have it sorting by PatNo, CNSDay
and AMT? The room# shouldn't have anything to do with it, should it?
 
J

Joel

I made two simple changes. Instead of testing for the last row using column
A I'm now using column B.


Sub DeleteDuplicates()
'
' Macro1 Macro
' Macro recorded 1/29/2008 by Joel Warburg
'

'
Lastrow = Range("B" & Rows.Count).End(xlUp).Row
'add auxilarry column with absolute amount
For RowCount = 2 To Lastrow
If Range("I" & RowCount) > 0 Then
Range("J" & RowCount) = Range("I" & RowCount)
Else
Range("J" & RowCount) = -1 * Range("I" & RowCount)
End If
Next RowCount
'sort data by Patient - CNSDay - Absolute Amount
Range("A2:J" & Lastrow).Sort _
Key1:=Range("B2"), _
MatchCase:=False, _
Key2:=Range("D2"), _
MatchCase:=False, _
Key3:=Range("J2"), _
MatchCase:=False

'delete duplicates
RowCount = 2
Do While Range("B" & RowCount) <> ""
If Range("B" & RowCount) = Range("B" & (RowCount + 1)) And _
Range("D" & RowCount) = Range("D" & (RowCount + 1)) And _
Range("I" & RowCount) = -1 * Range("I" & (RowCount + 1)) Then

Rows(RowCount).Delete

Else
RowCount = RowCount + 1
End If
Loop

'remove auxillary column J
Columns("J:J").Delete

End Sub
 
T

Tasha

Joel, It seems to be deleting the credits but not the matching debits. I
highlighted the items on a patient that should have been deleted in one
color, and the ones that should have stayed in another, and there were 2
debits left that should have been deleted along with the 2 matching
credits.~~Thank you so much again for helping me with this!!! You have no
idea how much I appreciate it!
 
J

Joel

Most people only want one of a duplicate row deleted. I forgot to remove the
2nd row. also there was a potential problem if there was two charges for the
same amount on the same day. The code wouldn't of worked properly under
this case. If fixed all the problems.


Sub DeleteDuplicates()
'
' Macro1 Macro
' Macro recorded 1/29/2008 by Joel Warburg
'

'
Lastrow = Range("B" & Rows.Count).End(xlUp).Row
'add auxilarry column with absolute amount
For RowCount = 2 To Lastrow
If Range("I" & RowCount) > 0 Then
Range("J" & RowCount) = Range("I" & RowCount)
Else
Range("J" & RowCount) = -1 * Range("I" & RowCount)
End If
Next RowCount
'sort data by Patient - CNSDay - Absolute Amount
Range("A2:J" & Lastrow).Sort _
Key1:=Range("B2"), _
MatchCase:=False, _
Key2:=Range("D2"), _
MatchCase:=False, _
Key3:=Range("J2"), _
MatchCase:=False

'delete duplicates
RowCount = 2
Do While Range("B" & RowCount) <> ""
Match = False
MatchRow = RowCount + 1
Do While Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("J" & RowCount) = Range("J" & MatchRow)


If Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("I" & RowCount) = -1 * Range("I" & MatchRow) Then

Match = True
Exit Do
End If
MatchRow = MatchRow + 1
Loop
If Match = True Then
Rows(MatchRow).Delete
Rows(RowCount).Delete
Else
RowCount = RowCount + 1
End If
Loop

'remove auxillary column J
Columns("J:J").Delete

End Sub
 
J

Joel

The last code was running a little slow. Deleting one row at a time
significantly slows down the code. the new code below marks all the rows
that need to be deleted by putting a true in column K. then it sorts by
column K to get all the trues together. Next it deltes the range of cells
that have True in them. It will run much faster.

Sub DeleteDuplicates1()
'
' Macro1 Macro
' Macro recorded 1/29/2008 by Joel Warburg
'

'
LastRow = Range("B" & Rows.Count).End(xlUp).Row
'add auxilarry column with absolute amount
For RowCount = 2 To LastRow
If Range("I" & RowCount) > 0 Then
Range("J" & RowCount) = Range("I" & RowCount)
Else
Range("J" & RowCount) = -1 * Range("I" & RowCount)
End If
Next RowCount
'sort data by Patient - CNSDay - Absolute Amount
Range("A2:J" & LastRow).Sort _
Key1:=Range("B2"), _
MatchCase:=False, _
Key2:=Range("D2"), _
MatchCase:=False, _
Key3:=Range("J2"), _
MatchCase:=False

'delete duplicates
'put true in column K if need to be deleted
RowCount = 2
Do While Range("B" & RowCount) <> ""
Match = False
MatchRow = RowCount + 1
Do While Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("J" & RowCount) = Range("J" & MatchRow)

If Range("K" & RowCount) <> True And _
Range("K" & MatchRow) <> True Then

If Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("I" & RowCount) = -1 * Range("I" & MatchRow) Then

Range("K" & RowCount) = True
Range("K" & MatchRow) = True
Exit Do
End If
End If

MatchRow = MatchRow + 1
Loop
RowCount = RowCount + 1
Loop
'Sort by column K which contains True if item should be deleted.
Range("A2:K" & LastRow).Sort _
Key1:=Range("K2")
LastRow = Range("K2").End(xlDown).Row
Rows("2" & ":" & LastRow).Delete

' If Match = True Then
' Rows(MatchRow).Delete
' Rows(RowCount).Delete

'remove auxillary columns J & K
Columns("J:K").Delete

End Sub
 
J

Joel

I found a slight problem with the 2nd method that runs faster. If there arre
no duplicates it clears the entire worksheet except for the header row. The
slower code doesn't havve the problem. The code below fixes this problem

Sub DeleteDuplicates1()
'
' Macro1 Macro
' Macro recorded 1/29/2008 by Joel Warburg
'

'
LastRow = Range("B" & Rows.Count).End(xlUp).Row
'add auxilarry column with absolute amount
For RowCount = 2 To LastRow
If Range("I" & RowCount) > 0 Then
Range("J" & RowCount) = Range("I" & RowCount)
Else
Range("J" & RowCount) = -1 * Range("I" & RowCount)
End If
Next RowCount
'sort data by Patient - CNSDay - Absolute Amount
Range("A2:J" & LastRow).Sort _
Key1:=Range("B2"), _
MatchCase:=False, _
Key2:=Range("D2"), _
MatchCase:=False, _
Key3:=Range("J2"), _
MatchCase:=False

'delete duplicates
'put true in column K if need to be deleted
RowCount = 2
Do While Range("B" & RowCount) <> ""
Match = False
MatchRow = RowCount + 1
Do While Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("J" & RowCount) = Range("J" & MatchRow)

If Range("K" & RowCount) <> True And _
Range("K" & MatchRow) <> True Then

If Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("I" & RowCount) = -1 * Range("I" & MatchRow) Then

Range("K" & RowCount) = True
Range("K" & MatchRow) = True
Exit Do
End If
End If

MatchRow = MatchRow + 1
Loop
RowCount = RowCount + 1
Loop
'Sort by column K which contains True if item should be deleted.
Range("A2:K" & LastRow).Sort _
Key1:=Range("K2")
If Range("K2") = True Then
LastRow = Range("K2").End(xlDown).Row
Rows("2" & ":" & LastRow).Delete
End If
' If Match = True Then
' Rows(MatchRow).Delete
' Rows(RowCount).Delete

'remove auxillary columns J & K
Columns("J:K").Delete

End Sub
 
T

Tasha

Joel,
Sorry it has taken me so long to copy the new code in and try it. I am
getting a Type Mismatch Error now. When I go into Debug, this part is
highlighted:

f Range("B" & RowCount) = Range("B" & MatchRow) And _
Range("D" & RowCount) = Range("D" & MatchRow) And _
Range("I" & RowCount) = -1 * Range("I" & MatchRow) Then

Thanks, for your help!!!
Tasha
 
T

Tasha

Joel, never mind, and thanks for all the work you did on this! I found the
problem, was my mistake!
Tasha
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Macro to delete rows 18

Top