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
Thinking also that this