I have a spreadsheet that is updated daily. I need a macro that will check
data for each record, in columns A,B,C and D, if they are the same, and the
data in Column I has a positive and negative amount that are the same, delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything matching in
columns A,B,C and D, and ONE debit and credit for the same amount needs rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every day
using filters, then deleting....is very time consuming!

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1, "I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will check
data for each record, in columns A,B,C and D, if they are the same, and
the
data in Column I has a positive and negative amount that are the same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything matching in
columns A,B,C and D, and ONE debit and credit for the same amount needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every day
using filters, then deleting....is very time consuming!

Thanks Bob!!! When I run this though, I am getting a syntax error??? What
would cause that?

"Bob Phillips" wrote:

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1, "I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will check
data for each record, in columns A,B,C and D, if they are the same, and
the
data in Column I has a positive and negative amount that are the same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything matching in
columns A,B,C and D, and ONE debit and credit for the same amount needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every day
using filters, then deleting....is very time consuming!

NG wrap-around. Try this instead

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = _
Abs(.Cells(i - 1, "I").Value) Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
Thanks Bob!!! When I run this though, I am getting a syntax error??? What
would cause that?

"Bob Phillips" wrote:

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1, "I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will
check
data for each record, in columns A,B,C and D, if they are the same, and
the
data in Column I has a positive and negative amount that are the same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything matching
in
columns A,B,C and D, and ONE debit and credit for the same amount needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every day
using filters, then deleting....is very time consuming!

It looks to me like only rows 4 and 5 (spreadsheet rows 5 and 6) should
be deleted, so there would still be 4 rows of data left, instead of only
2!
Also, what does the asterisk after the AMT mean? If it appears on a
debit, and not on a credit, then should those 2 rows be deleted?

These types of data situations can become rather complex to do in Excel
VBA, as a programmer should not assume that rows of data will be in any
particular order. Is there some other exported report that you should be
getting from your information system and using? (No wonder that health
care is so expensive! Smile!)
--
Regards,
Bill Renaud

Yes, you are right, there should have been 4 rows left, I was in a hurry when
I posted that....** sorry ** The asterisks were only me showing which
ones I was specifying....not included in the report. And again, you're
right, in that the data would not be in any particular order, which is why I
have been doing this manually. And no, there is no 'other' report to get
this information from....some healthcare systems are not real easy to pull
information from....thus time spent manipulating queries from databases, and
all the questions I have had answered here :) Thinking also that this
isn't the reason healthcare is so expensive!!....but.... another time another
place :)

"Bill Renaud" wrote:

It looks to me like only rows 4 and 5 (spreadsheet rows 5 and 6) should
be deleted, so there would still be 4 rows of data left, instead of only
2!
Also, what does the asterisk after the AMT mean? If it appears on a
debit, and not on a credit, then should those 2 rows be deleted?

These types of data situations can become rather complex to do in Excel
VBA, as a programmer should not assume that rows of data will be in any
particular order. Is there some other exported report that you should be
getting from your information system and using? (No wonder that health
care is so expensive! Smile!)
--
Regards,
Bill Renaud

Bob, no more syntax error, but it's only deleting the debits, not the credits?

"Bob Phillips" wrote:

NG wrap-around. Try this instead

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = _
Abs(.Cells(i - 1, "I").Value) Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
Thanks Bob!!! When I run this though, I am getting a syntax error??? What
would cause that?

"Bob Phillips" wrote:

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1, "I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will
check
data for each record, in columns A,B,C and D, if they are the same, and
the
data in Column I has a positive and negative amount that are the same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything matching
in
columns A,B,C and D, and ONE debit and credit for the same amount needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every day
using filters, then deleting....is very time consuming!

So, the original post should have looked like the following, with the
asterisk at the end meaning "these 2 rows should be deleted", the other
row with a debit for 953.80 should be left in the data set. (I deleted
some spaces to tighten up your original post; hopefully it won't word
wrap in the NG):

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED 1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU 1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED 1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU 1 953.80 *
ICU1 167 SCHMOE JOE 12 2 M ICU 1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED 1 953.80

After the macro runs, it would look like the following (data rows 2 and
4 are still listed, because they are both debits):
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED 1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU 1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED 1 1293.00
ICU1 167 SCHMOE JOE 12 2 M MED 1 953.80

Is any sort order OK, or do you want it returned to the original order?

Some final (silly) questions:
1. Why do the 2 rows need to be deleted?
2. What happens if there are 3 rows all totaling up to $0 (1 debit for
953.90, 1 credit for 500.00, and another credit for 453.90)?
3. Are you absolutely certain (100%) that you do not need to check the
other 4 columns to see if they match (DAYS, F_C, and HSV)?
--
Regards,
Bill Renaud

Can you clarify what you mean?

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
Bob, no more syntax error, but it's only deleting the debits, not the
credits?

"Bob Phillips" wrote:

NG wrap-around. Try this instead

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = _
Abs(.Cells(i - 1, "I").Value) Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
Thanks Bob!!! When I run this though, I am getting a syntax error???
What
would cause that?

"Bob Phillips" wrote:

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1,
"I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will
check
data for each record, in columns A,B,C and D, if they are the same,
and
the
data in Column I has a positive and negative amount that are the
same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M
MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M
MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M
MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything
matching
in
columns A,B,C and D, and ONE debit and credit for the same amount
needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M
MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M
MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every
day
using filters, then deleting....is very time consuming!

let me see if I can explain this in a short reply. The report shows
npatients room charges, changes daily due to the fact that they may be moved
in/out of a room/service (such as from Medical Inpatient to ICU), so the
billing office will take charges off and put new ones on accordingly. That
is what this report portrays. So, in order to get an accurate count of
patient days, I need to delete off from each account the debit and credit
that matches(if there is a credit) by patient number, service date and
amount. This is a couple of example's from today's report....privacy info
removed.....hoping it won't wrap. As you can see, more so in the 2nd
patient, there are often errors in the HSV, so we can't make them match, it
would have to match by amount(credit or debit). The billing office credited
the account from ICU, and it should have been MIP, however the amount is what
needs removed, both debit and credit. Hope this makes sense.

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU4 360 FRANKO AMER 10 2 M ICU 1 (1,293.60)
ICU4 360 FRANKO AMER 10 2 M ICU 1 965.80
ICU4 360 FRANKO AMER 10 2 M ICU 1 1,293.60
ICU4 360 FRANKO AMER 11 2 M ICU 1 (1,293.60)
ICU4 360 FRANKO AMER 11 2 M ICU 1 965.80
ICU4 360 FRANKO AMER 11 2 M ICU 1 1,293.60
1632 713 MAYER OSCAR 14 0 M MIP 1 965.80
1632 713 MAYER OSCAR 15 0 M MIP 1 965.80
1632 713 MAYER OSCAR 16 0 M MIP 1 965.80
1632 713 MAYER OSCAR 17 0 M MIP 1 965.80
1632 713 MAYER OSCAR 17 0 M ICU 1 (965.80)
1632 713 MAYER OSCAR 17 0 M ICU 1 1,293.60
1632 713 MAYER OSCAR 17 0 M ISO 1 1,153.00
1632 713 MAYER OSCAR 17 0 M ICU 1 (1,293.60)
{the last patient has 4 patient days, 3 in MIP, and
1 in ISO after all the credits/debits were deducted.}






"Bill Renaud" wrote:

So, the original post should have looked like the following, with the
asterisk at the end meaning "these 2 rows should be deleted", the other
row with a debit for 953.80 should be left in the data set. (I deleted
some spaces to tighten up your original post; hopefully it won't word
wrap in the NG):

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED 1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU 1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED 1 1293.00
ICU1 167 SCHMOE JOE 12 2 M ICU 1 953.80 *
ICU1 167 SCHMOE JOE 12 2 M ICU 1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M MED 1 953.80

After the macro runs, it would look like the following (data rows 2 and
4 are still listed, because they are both debits):
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY AMT
ICU1 167 SCHMOE JOE 11 1 M MED 1 953.80
ICU1 167 SCHMOE JOE 12 2 M ICU 1 953.80
ICU1 167 SCHMOE JOE 13 3 M MED 1 1293.00
ICU1 167 SCHMOE JOE 12 2 M MED 1 953.80

Is any sort order OK, or do you want it returned to the original order?

Some final (silly) questions:
1. Why do the 2 rows need to be deleted?
2. What happens if there are 3 rows all totaling up to $0 (1 debit for
953.90, 1 credit for 500.00, and another credit for 453.90)?
3. Are you absolutely certain (100%) that you do not need to check the
other 4 columns to see if they match (DAYS, F_C, and HSV)?
--
Regards,
Bill Renaud

Hi Tasha,

Here is some code that you can try (hope you are still checking the NG
every once in a while). I decided to write the routine, just to see what
was really involved in this type of situation. It is amazing how
something that appears relatively simple to a human can require several
(possibly hundreds of) lines of code to solve! I developed this with
Excel 2000, so hopefully it will run on whatever version you are using.

Just paste this code into a standard module in a new, empty workbook,
then attach a toolbar button to it. As always, watch for unwanted
word-wrap in the NG. Make sure that the worksheet with the data is the
active sheet when you start the macro. The macro will add 3 columns to
the right of your data, for sorting purposes, as well as marking the
rows that should be deleted. You will be prompted at the start for just
marking the rows, or marking and then automatically deleting them.

Check these results carefully to make sure it meets your needs!

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
& "and then delete duplicate rows." & vbNewLine _
& vbNewLine _
& "Press No to mark rows for deletion," & vbNewLine
_
& "but not automatically delete them.", _
vbExclamation + vbYesNo, _
strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

If varResponse = vbYes Then DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.
For ilngCompare1 = ilngFirst To ilngLast - 1
If rngDelete(ilngCompare1) < conDELETE _
Then
For ilngCompare2 = ilngCompare1 + 1 To ilngLast
If rngDelete(ilngCompare2) < conDELETE _
Then
If rngAmt(ilngCompare1) = -rngAmt(ilngCompare2) _
Then
'Mark both patient records for deletion.
rngDelete(ilngCompare1) = conDELETE
rngDelete(ilngCompare2) = conDELETE

'Must now exit inner For loop, since
'Compare1 has now been marked for deletion.
Exit For
End If
End If
Next ilngCompare2
End If
Next ilngCompare1
End If
Wend
End Sub

'----------------------------------------------------------------------
Private Sub DeleteMarkedRows()
Dim rngDelete As Range 'Data area of Delete column.
Dim rngMarkedRows As Range 'Cells in Delete column with "Delete".

Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))
Set rngMarkedRows = rngDelete.SpecialCells(xlCellTypeConstants)

rngMarkedRows.EntireRow.Delete
End Sub

--
Regards,
Bill Renaud

I don't understand what you mean.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
Bob, no more syntax error, but it's only deleting the debits, not the
credits?

"Bob Phillips" wrote:

NG wrap-around. Try this instead

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = _
Abs(.Cells(i - 1, "I").Value) Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
Thanks Bob!!! When I run this though, I am getting a syntax error???
What
would cause that?

"Bob Phillips" wrote:

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1,
"I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will
check
data for each record, in columns A,B,C and D, if they are the same,
and
the
data in Column I has a positive and negative amount that are the
same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M
MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M
MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M
MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything
matching
in
columns A,B,C and D, and ONE debit and credit for the same amount
needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M
MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M
MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every
day
using filters, then deleting....is very time consuming!

sorry to sound dumb??? what is NG? Thank you for going to all the
trouble!!!, I will try to use this and let you know if it works.....

"Bill Renaud" wrote:

Hi Tasha,

Here is some code that you can try (hope you are still checking the NG
every once in a while). I decided to write the routine, just to see what
was really involved in this type of situation. It is amazing how
something that appears relatively simple to a human can require several
(possibly hundreds of) lines of code to solve! I developed this with
Excel 2000, so hopefully it will run on whatever version you are using.

Just paste this code into a standard module in a new, empty workbook,
then attach a toolbar button to it. As always, watch for unwanted
word-wrap in the NG. Make sure that the worksheet with the data is the
active sheet when you start the macro. The macro will add 3 columns to
the right of your data, for sorting purposes, as well as marking the
rows that should be deleted. You will be prompted at the start for just
marking the rows, or marking and then automatically deleting them.

Check these results carefully to make sure it meets your needs!

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
& "and then delete duplicate rows." & vbNewLine _
& vbNewLine _
& "Press No to mark rows for deletion," & vbNewLine
_
& "but not automatically delete them.", _
vbExclamation + vbYesNo, _
strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

If varResponse = vbYes Then DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.
For ilngCompare1 = ilngFirst To ilngLast - 1
If rngDelete(ilngCompare1) < conDELETE _
Then
For ilngCompare2 = ilngCompare1 + 1 To ilngLast
If rngDelete(ilngCompare2) < conDELETE _
Then
If rngAmt(ilngCompare1) = -rngAmt(ilngCompare2) _
Then
'Mark both patient records for deletion.
rngDelete(ilngCompare1) = conDELETE
rngDelete(ilngCompare2) = conDELETE

I was getting a syntax error, but am not now, someone else had replied as
well, and have been working on getting it to work.....thank you though for
the reply....you've always been a huge help!!!

"Bob Phillips" wrote:

I don't understand what you mean.

--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my addy)

"Tasha" wrote in message
...
Bob, no more syntax error, but it's only deleting the debits, not the
credits?

"Bob Phillips" wrote:

NG wrap-around. Try this instead

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = _
Abs(.Cells(i - 1, "I").Value) Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
Thanks Bob!!! When I run this though, I am getting a syntax error???
What
would cause that?

"Bob Phillips" wrote:

I have a few more left than you

Public Sub ProcessData()
Dim i As Long
Dim iLastRow As Long

With ActiveSheet

iLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = iLastRow To 3 Step -1
If .Cells(i, "A").Value = .Cells(i - 1, "A").Value And _
.Cells(i, "B").Value = .Cells(i - 1, "B").Value And _
.Cells(i, "C").Value = .Cells(i - 1, "C").Value And _
.Cells(i, "D").Value = .Cells(i - 1, "D").Value And _
Abs(.Cells(i, "I").Value) = Abs(.Cells(i - 1,
"I").Value)
Then
.Rows(i).Delete
End If
Next i
End With

End Sub


--
HTH

Bob

(there's no email, no snail mail, but somewhere should be gmail in my
addy)

"Tasha" wrote in message
...
I have a spreadsheet that is updated daily. I need a macro that will
check
data for each record, in columns A,B,C and D, if they are the same,
and
the
data in Column I has a positive and negative amount that are the
same,
delete
both rows. See Example Below:

ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M
MED
1 953.80
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 953.80*
ICU1 167 SCHMOE JOE 13 3 M
MED
1 1293.00
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 953.80*
ICU1 167 SCHMOE JOE 12 2 M
ICU
1 (953.80)*
ICU1 167 SCHMOE JOE 12 2 M
MED
1 953.80
(would need it to delete the 2nd and 3rd rows, with everything
matching
in
columns A,B,C and D, and ONE debit and credit for the same amount
needs
rows
deleted....if not same info and amounts, rows not deleted.

would end up looking like this:
ROOM PATNO PATNAME CNSDAY DAYS F_C HSV QTY
AMT
ICU1 167 SCHMOE JOE 11 1 M
MED
1 953.80
ICU1 167 SCHMOE JOE 13 3 M
MED
1 1293.00

Is there any way to do this? I'm currently doing it manually every
day
using filters, then deleting....is very time consuming!

NG=NewsGroup

Where you posted this message.

Tasha wrote:

sorry to sound dumb??? what is NG? Thank you for going to all the
trouble!!!, I will try to use this and let you know if it works.....

"Bill Renaud" wrote:

Hi Tasha,

Here is some code that you can try (hope you are still checking the NG
every once in a while). I decided to write the routine, just to see what
was really involved in this type of situation. It is amazing how
something that appears relatively simple to a human can require several
(possibly hundreds of) lines of code to solve! I developed this with
Excel 2000, so hopefully it will run on whatever version you are using.

Just paste this code into a standard module in a new, empty workbook,
then attach a toolbar button to it. As always, watch for unwanted
word-wrap in the NG. Make sure that the worksheet with the data is the
active sheet when you start the macro. The macro will add 3 columns to
the right of your data, for sorting purposes, as well as marking the
rows that should be deleted. You will be prompted at the start for just
marking the rows, or marking and then automatically deleting them.

Check these results carefully to make sure it meets your needs!

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
& "and then delete duplicate rows." & vbNewLine _
& vbNewLine _
& "Press No to mark rows for deletion," & vbNewLine
_
& "but not automatically delete them.", _
vbExclamation + vbYesNo, _
strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

If varResponse = vbYes Then DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.
For ilngCompare1 = ilngFirst To ilngLast - 1
If rngDelete(ilngCompare1) < conDELETE _
Then
For ilngCompare2 = ilngCompare1 + 1 To ilngLast
If rngDelete(ilngCompare2) < conDELETE _
Then
If rngAmt(ilngCompare1) = -rngAmt(ilngCompare2) _
Then
'Mark both patient records for deletion.
rngDelete(ilngCompare1) = conDELETE
rngDelete(ilngCompare2) = conDELETE

--

Dave Peterson

ahhh :) Thanks Dave.....sometimes what should be obvious, most often isn't !

"Dave Peterson" wrote:

NG=NewsGroup

Where you posted this message.

Tasha wrote:

sorry to sound dumb??? what is NG? Thank you for going to all the
trouble!!!, I will try to use this and let you know if it works.....

"Bill Renaud" wrote:

Hi Tasha,

Here is some code that you can try (hope you are still checking the NG
every once in a while). I decided to write the routine, just to see what
was really involved in this type of situation. It is amazing how
something that appears relatively simple to a human can require several
(possibly hundreds of) lines of code to solve! I developed this with
Excel 2000, so hopefully it will run on whatever version you are using.

Just paste this code into a standard module in a new, empty workbook,
then attach a toolbar button to it. As always, watch for unwanted
word-wrap in the NG. Make sure that the worksheet with the data is the
active sheet when you start the macro. The macro will add 3 columns to
the right of your data, for sorting purposes, as well as marking the
rows that should be deleted. You will be prompted at the start for just
marking the rows, or marking and then automatically deleting them.

Check these results carefully to make sure it meets your needs!

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
& "and then delete duplicate rows." & vbNewLine _
& vbNewLine _
& "Press No to mark rows for deletion," & vbNewLine
_
& "but not automatically delete them.", _
vbExclamation + vbYesNo, _
strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

If varResponse = vbYes Then DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.

I am sorry it has taken me so long to get back to you. Thank you so much for
all the hard work and line after line of code you wrote for me....it works
PERFECT! PERFECT, PERFECT PERFECT!! Thank you again so much for your
time!!!! I will be forever grateful!!!!

"Bill Renaud" wrote:

Hi Tasha,

Here is some code that you can try (hope you are still checking the NG
every once in a while). I decided to write the routine, just to see what
was really involved in this type of situation. It is amazing how
something that appears relatively simple to a human can require several
(possibly hundreds of) lines of code to solve! I developed this with
Excel 2000, so hopefully it will run on whatever version you are using.

Just paste this code into a standard module in a new, empty workbook,
then attach a toolbar button to it. As always, watch for unwanted
word-wrap in the NG. Make sure that the worksheet with the data is the
active sheet when you start the macro. The macro will add 3 columns to
the right of your data, for sorting purposes, as well as marking the
rows that should be deleted. You will be prompted at the start for just
marking the rows, or marking and then automatically deleting them.

Check these results carefully to make sure it meets your needs!

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
& "and then delete duplicate rows." & vbNewLine _
& vbNewLine _
& "Press No to mark rows for deletion," & vbNewLine
_
& "but not automatically delete them.", _
vbExclamation + vbYesNo, _
strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

If varResponse = vbYes Then DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.
For ilngCompare1 = ilngFirst To ilngLast - 1
If rngDelete(ilngCompare1) < conDELETE _
Then
For ilngCompare2 = ilngCompare1 + 1 To ilngLast
If rngDelete(ilngCompare2) < conDELETE _
Then
If rngAmt(ilngCompare1) = -rngAmt(ilngCompare2) _
Then
'Mark both patient records for deletion.
rngDelete(ilngCompare1) = conDELETE
rngDelete(ilngCompare2) = conDELETE

Bill, going to bug you again. Is there a way to remove the message box and
have it go ahead and delete the rows? I tested it and works, and will always
need it to delete, not mark, so if possible would like to have it just do it
instead of stopping in the middle of the macro.... I hate to ask after all
you did, but you help me with this???

"Bill Renaud" wrote:

Hi Tasha,

Here is some code that you can try (hope you are still checking the NG
every once in a while). I decided to write the routine, just to see what
was really involved in this type of situation. It is amazing how
something that appears relatively simple to a human can require several
(possibly hundreds of) lines of code to solve! I developed this with
Excel 2000, so hopefully it will run on whatever version you are using.

Just paste this code into a standard module in a new, empty workbook,
then attach a toolbar button to it. As always, watch for unwanted
word-wrap in the NG. Make sure that the worksheet with the data is the
active sheet when you start the macro. The macro will add 3 columns to
the right of your data, for sorting purposes, as well as marking the
rows that should be deleted. You will be prompted at the start for just
marking the rows, or marking and then automatically deleting them.

Check these results carefully to make sure it meets your needs!

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
& "and then delete duplicate rows." & vbNewLine _
& vbNewLine _
& "Press No to mark rows for deletion," & vbNewLine
_
& "but not automatically delete them.", _
vbExclamation + vbYesNo, _
strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

If varResponse = vbYes Then DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.
For ilngCompare1 = ilngFirst To ilngLast - 1
If rngDelete(ilngCompare1) < conDELETE _
Then
For ilngCompare2 = ilngCompare1 + 1 To ilngLast
If rngDelete(ilngCompare2) < conDELETE _
Then
If rngAmt(ilngCompare1) = -rngAmt(ilngCompare2) _
Then
'Mark both patient records for deletion.
rngDelete(ilngCompare1) = conDELETE
rngDelete(ilngCompare2) = conDELETE

Hi Tasha!

<<Is there a way to remove the message box and have it go ahead and delete
the rows?

Why soooorrrrrttteeeenly (bad 3 Stooges imitation)! Just comment out the
prompt for the message box and the If statement further down the program
before deleting the rows (note the single apostrophes at the left of the
text)! (I personally don't recommend doing this; your supervisor might want
to verify how you computed the result someday!!!)

(Good thing I was still watching this thread! I almost deleted it to clear
some space in Outlook Express!)

Anyway, here is the revised code. I would recommend saving both macros, in
case you ever need the first version again!

====================================
Option Explicit

'----------------------------------------------------------------------
'Global constants and variables
Const strMsgBoxTitle = "Delete Duplicate Rows"
Const conDELETE = "Delete" 'Constant to use to fill in Delete column.

Dim rngList As Range 'List of all data on the worksheet.

'----------------------------------------------------------------------
Public Sub DeleteDuplicateRows()
' Dim varResponse As Variant 'vbYes or vbNo for DeleteMarkedRows.

Set rngList = ActiveSheet.UsedRange

If Not IsWorksheetValid Then GoTo ExitSub

' varResponse = MsgBox("Press Yes to automatically mark" & vbNewLine _
' & "and then delete duplicate rows." & vbNewLine _
' & vbNewLine _
' & "Press No to mark rows for deletion," & vbNewLine _
' & "but not automatically delete them.", _
' vbExclamation + vbYesNo, _
' strMsgBoxTitle)

Application.ScreenUpdating = False

'Add 3 columns at the right side of the data
'for sorting and processing purposes.
AppendHeaderCell conDELETE
AddOrderColumn
AddSortingColumn

FormatHeaderCells 'Format all column labels (headers).
MarkRowsForDeletion 'Mark rows to be deleted.

'If varResponse = vbYes Then
DeleteMarkedRows

SortList "Order" 'Re-sort data back to original order.

'Autofit columns for easier viewing.
rngList.Parent.Columns.AutoFit

ExitSub:
Application.ScreenUpdating = True
End Sub

'----------------------------------------------------------------------
Private Function IsWorksheetValid() As Boolean
Dim rngRoom As Range
Dim rngPatNo As Range
Dim rngPatName As Range
Dim rngCNSDay As Range
Dim rngAmt As Range

Dim rngDelete As Range
Dim rngOrder As Range
Dim rngSort As Range

'Check for column labels that SHOULD be present.
Set rngRoom = GetHeaderCell("ROOM")
Set rngPatNo = GetHeaderCell("PATNO")
Set rngPatName = GetHeaderCell("PATNAME")
Set rngCNSDay = GetHeaderCell("CNSDAY")
Set rngAmt = GetHeaderCell("AMT")

If (rngRoom Is Nothing) _
Or (rngPatNo Is Nothing) _
Or (rngPatName Is Nothing) _
Or (rngCNSDay Is Nothing) _
Or (rngAmt Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet is not a valid data set." & vbNewLine _
& vbNewLine _
& "Does not contain ""ROOM"", ""PATNO""," & vbNewLine _
& """PATNAME"", ""CNSDAY"", or ""AMT"" columns.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check for column labels that should NOT be present.
Set rngDelete = GetHeaderCell(conDELETE)
Set rngOrder = GetHeaderCell("Order")
Set rngSort = GetHeaderCell("SortingColumn")

If Not (rngDelete Is Nothing) _
Or Not (rngOrder Is Nothing) _
Or Not (rngSort Is Nothing) _
Then
IsWorksheetValid = False
MsgBox "Worksheet has already been processed.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

'Check that there is least 1 row of data to process.
If (rngList.Rows.Count < 2) _
Then
IsWorksheetValid = False
MsgBox "No data to process.", _
vbCritical + vbOKOnly, _
strMsgBoxTitle
GoTo ExitIsWorksheetValid
End If

IsWorksheetValid = True

ExitIsWorksheetValid:
End Function

'----------------------------------------------------------------------
Private Sub AddOrderColumn()
Dim rngOrder As Range
Dim rngOrderData As Range

Set rngOrder = AppendHeaderCell("Order")
Set rngOrderData = GetDataArea(rngOrder)

'Put a value of 1 in the first cell.
rngOrderData.Cells(1, 1).Formula = 1#

'Now fill in the data series, sequentially by 1.
rngOrderData.DataSeries Rowcol:=xlColumns, _
Type:=xlLinear, _
Step:=1, _
Trend:=False
End Sub

'----------------------------------------------------------------------
Private Sub AddSortingColumn()
Dim rngSortingHeader As Range
Dim rngSortingData As Range

Set rngSortingHeader = AppendHeaderCell("SortingColumn")
Set rngSortingData = GetDataArea(rngSortingHeader)

'Add data to SortingColumn (sort by PATNAME, PATNO, CNSDAY, and ROOM).
rngSortingData.Formula = "=" & CellAddress("PATNAME", 1) _
& " & "" "" & " & CellAddress("PATNO", 1) _
& " & "" "" & " & CellAddress("CNSDAY", 1) _
& " & "" "" & " & CellAddress("ROOM", 1)
End Sub

'----------------------------------------------------------------------
Private Function AppendHeaderCell(strHeader As String) As Range

Dim rngNewHeaderCell As Range

'Add new column at the right of the list. Assume column is emtpy.
With rngList
Set rngNewHeaderCell = .Resize(1, 1) _
.Offset(ColumnOffset:=.Columns.Count)
End With

rngNewHeaderCell.Formula = strHeader

'Expand width of List to include the new column.
With rngList
Set rngList = .Resize(ColumnSize:=.Columns.Count + 1)
End With

Set AppendHeaderCell = rngNewHeaderCell
End Function

'----------------------------------------------------------------------
Private Sub FormatHeaderCells()
With rngList.Resize(RowSize:=1)
.Font.Bold = True
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End Sub

'----------------------------------------------------------------------
Private Function GetHeaderCell(strHeader As String) As Range

Dim rngHeaderCells As Range

Set rngHeaderCells = rngList.Resize(1)

Set GetHeaderCell = rngHeaderCells.Find(What:=strHeader, _
LookIn:=xlValues, _
LookAt:=xlPart)
End Function

'----------------------------------------------------------------------
Private Function GetDataArea(rngHeaderCell As Range) As Range

With rngHeaderCell
Set GetDataArea = .Offset(1, 0) _
.Resize(RowSize:=rngList.Rows.Count - 1)
End With
End Function

'----------------------------------------------------------------------
Private Function CellAddress(strHeaderCell As String, _
lngOffset As Long) As String

CellAddress = GetHeaderCell(strHeaderCell) _
.Offset(RowOffset:=lngOffset) _
.Address(RowAbsolute:=False, _
ColumnAbsolute:=False, _
ReferenceStyle:=xlA1)
End Function

'----------------------------------------------------------------------
Private Sub SortList(strHeaderCell As String)
Dim rngHeaderCell As Range

Set rngHeaderCell = GetHeaderCell(strHeaderCell)

rngList.Sort Key1:=rngHeaderCell, Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom
End Sub

'----------------------------------------------------------------------
Private Sub MarkRowsForDeletion()
Dim rngSort As Range 'Data area of SortingColumn.
Dim rngAmt As Range 'Data area of AMT column.
Dim rngDelete As Range 'Data area of Delete column.

Dim ilngFirst As Long 'Index to First record of a given patient.
Dim ilngLast As Long 'Index to Last record of a given patient.
Dim ilngEnd As Long 'Index to End record of all data.
Dim ilngCompare1 As Long 'Index to first record to compare.
Dim ilngCompare2 As Long 'Index to second record to compare.

'Sort data using the SortingColumn.
SortList "SortingColumn"

'Get references to data areas of
'"SortingColumn", "AMT", and "Delete" columns.
Set rngSort = GetDataArea(GetHeaderCell("SortingColumn"))
Set rngAmt = GetDataArea(GetHeaderCell("AMT"))
Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))

'Initialize the loop.
ilngEnd = rngSort.Rows.Count
ilngLast = 0

'Loop to look for any records to be marked for deletion.
While (ilngLast < ilngEnd)
ilngFirst = ilngLast + 1
ilngLast = ilngFirst

'Find last row of data for this same
'patient-room combination etc.
While (ilngLast < ilngEnd)
If rngSort(ilngLast + 1) = rngSort(ilngLast) _
Then
ilngLast = ilngLast + 1
Else
GoTo CompareRecords
End If
Wend

CompareRecords:
'Compare all combinations or patient records that
'have not already been marked for deletion,
'then mark both for deletion.
If (ilngLast - ilngFirst) 0 _
Then
'There are at least 2 records, so they can be compared.
For ilngCompare1 = ilngFirst To ilngLast - 1
If rngDelete(ilngCompare1) < conDELETE _
Then
For ilngCompare2 = ilngCompare1 + 1 To ilngLast
If rngDelete(ilngCompare2) < conDELETE _
Then
If rngAmt(ilngCompare1) = -rngAmt(ilngCompare2) _
Then
'Mark both patient records for deletion.
rngDelete(ilngCompare1) = conDELETE
rngDelete(ilngCompare2) = conDELETE

'Must now exit inner For loop, since
'Compare1 has now been marked for deletion.
Exit For
End If
End If
Next ilngCompare2
End If
Next ilngCompare1
End If
Wend
End Sub

'----------------------------------------------------------------------
Private Sub DeleteMarkedRows()
Dim rngDelete As Range 'Data area of Delete column.
Dim rngMarkedRows As Range 'Cells in Delete column with "Delete".

Set rngDelete = GetDataArea(GetHeaderCell(conDELETE))
Set rngMarkedRows = rngDelete.SpecialCells(xlCellTypeConstants)

rngMarkedRows.EntireRow.Delete
End Sub

--
Regards,
Bill Renaud