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