Hi again Sue,

As per my message yesterday, don't forget to keep a backup of your data.

Copy both macros in again. I have rewritten the delete one. Rows should be
deleted in the reverse order from the bottom not from the top otherwise there
are problems deleting adjacent rows because the row where the code is up to
gets deleted and the program looses its place.

I have put proper line breaks (Space and underscore) in the long lines of
code so that hopefully you should not have to edit them. (I usually do this
and I forgot yesterday.)

Sub Mark_for_Delete()
Dim c As Range 'Cell in column H
Dim strHRID As String
Dim foundHRID As Range
Dim strFirstAddr As String
Dim datePrior As Date

'NOTE: If altering the date between # # then enter date
'using the the alpha characters for the month and let
'Excel reset to numerics.
'Example Jan 1 2007 or 1 Jan 2007 is acceptable.

datePrior = #1/1/2007#

Sheets("Sheet1").Select
For Each c In Range("H:H")
'Next line tests for blank in column A
'and assumes end of data if it is blank
If c.Offset(0, -7) = "" Then Exit For

'Test if Current and Term are blank
If c.Value = "" And c.Offset(0, 1).Value = "" Then
c.Offset(0, 2).Value = "Ignore"
GoTo skipToNextc
Else
'Test for text column header
If c.Value < "" And IsDate(c.Value) = False Then
GoTo skipToNextc
End If
End If


'Test if Current blank and Term populated
If c.Value = "" And c.Offset(0, 1).Value 0 Then
'Save value and address of HRID
strHRID = c.Offset(0, -7).Value
strFirstAddr = c.Offset(0, -7).Address

'Find strHRID
Set foundHRID = Columns("A:A") _
.Find(What:=strHRID, _
After:=c.Offset(0, -7), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

'Not necessary to test if found because
'must find at least one at the current c.row.

Do
'Test if not found at current row
If foundHRID.Address < strFirstAddr Then
'Found but not at current c.row
'Test if Current and Term are blank
If foundHRID.Offset(0, 7) = "" And _
foundHRID.Offset(0, 8) = "" Then
'Both blank so write Delete to column J.
c.Offset(0, 2).Value = "Delete"
c.Offset(0, 2).Interior.ColorIndex = 3
'Write duplicate row number to column K
c.Offset(0, 3).Value = "Duplicate Row " & _
foundHRID.Row
Exit Do 'No additional find require
Else
'Not both blank so look for another record
Set foundHRID = Columns("A:A") _
.FindNext(foundHRID)
End If
Else
'Only one record Current blank and Term populated
Exit Do
End If
Loop While Not foundHRID Is Nothing And _
foundHRID.Address < strFirstAddr
GoTo skipToNextc
End If

'Test if current and term are populated
If c.Value 0 And c.Offset(0, 1).Value 0 Then
'test if current and term less than datePrior
If c.Value < datePrior And _
c.Offset(0, 1).Value < datePrior Then
c.Offset(0, 2).Value = "Delete"
c.Offset(0, 2).Interior.ColorIndex = 3
GoTo skipToNextc
Else

'Save value HRID
strHRID = c.Offset(0, -7).Value
'Find strHRID
strFirstAddr = c.Offset(0, -7).Address

Set foundHRID = Columns("A:A") _
.Find(What:=strHRID, _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)

Do
'Test if NOT found at current row
If foundHRID.Address < strFirstAddr Then
'Found but NOT at current c.row
'Test for Current populated and Term blank
If foundHRID.Offset(0, 7) 0 And _
foundHRID.Offset(0, 8) = "" Then
'Current populated Term blank true.Delete row
foundHRID.Offset(0, 9).Value = "Delete"
foundHRID.Offset(0, 9).Interior.ColorIndex = 3
'Write duplicate row number to column K
foundHRID.Offset(0, 10).Value = _
"Duplicate Row " & c.Row
End If
Set foundHRID = Columns("A:A").FindNext(foundHRID)
Else
'Columns("A:A").FindNext(foundHRID).Activate
'Set foundHRID = ActiveCell
Set foundHRID = Columns("A:A").FindNext(foundHRID)
End If
Loop While Not foundHRID Is Nothing And _
foundHRID.Address < strFirstAddr
c.Offset(0, 2).Value = "Recent"
End If
End If
skipToNextc:
Next c
'Auto fir columns J and K
Columns("J:K").Columns.AutoFit

End Sub

Sub Delete_Rows()

Dim c As Range 'Cell in column H

Sheets("Sheet1").Select
For Each c In Range("J:J")
'Next line tests for blank in column A
'and assumes end of data if it is blank
If c.Offset(0, -7) = "" Then Exit For

If c.Value = "Delete" Then
c.EntireRow.Delete
End If
Next c

End Sub

Sub Delete_Rows_2()
Dim rngColJ As Range
Dim c As Long

'Note: looks in column J for deletes.
With Sheets("Sheet1")
Set rngColJ = Range(.Cells(2, "J"), .Cells(.Rows.Count, "J").End(xlUp))
End With

With rngColJ
'Step backwards from bottom
For c = .Rows.Count To 2 Step -1
If .Cells(c, 1) = "Delete" Then
.Cells(c, 1).EntireRow.Delete
End If
Next c
End With

End Sub



Regards,

OssieMac