Option Explicit
Const cMZ As Long = 2
Const cP As Long = 10
Const cStdDev2 As Long = 12
Const cNO As Long = 14
Const cNSO As Long = 15
Const cHC As Long = 16
Dim rData As Range
Sub DeleteSomeRows()
Dim rData1 As Range
Dim iRow As Long, iStart As Long, iEnd As Long
Dim aCounts() As Long, aChecks() As Long
'testing to init data
' Worksheets("HA_MM_7_0915_NB_MF_proc_reduced").Columns("B:P").Copy
' Sheets("Results").Select
' Range("B1").Select
' ActiveSheet.Paste
'------------------------------------------------
'setup - sort in MZ ascending order
Application.ScreenUpdating = False
Set rData = ActiveSheet.Cells(1, 1).CurrentRegion
Set rData1 = rData.Cells(2, 1).Resize(rData.Rows.Count - 1, rData.Columns.Count)
Application.StatusBar = "Sorting"
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=rData1.Columns(cMZ), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rData
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'---------------------------------------------------------------------------
'pass #1 - for a MZ with 2+ rows, delete if
' a NO and NSO outside on row
iStart = 2
iEnd = iStart
With rData
For iRow = 2 To .Rows.Count
Application.StatusBar = "Pass #1 - Row " & iRow
If .Cells(iRow + 1, cMZ).Value = .Cells(iRow, cMZ).Value Then
iEnd = iEnd + 1
Else
If iStart <> iEnd Then Call CheckData1(iStart, iEnd)
iStart = iRow + 1
iEnd = iStart
End If
Next iRow
End With
On Error Resume Next
rData.Columns(cMZ).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0
'---------------------------------------------------------------------------
'pass #2 - for a MZ with 2+ rows, delete if
' a NO not outside and NSO outside on row
' b NO outside and NSO not outside on row
' c All rows have either NO or NSO outside
iStart = 2
iEnd = iStart
With rData
For iRow = 2 To .Rows.Count
Application.StatusBar = "Pass #2 - Row " & iRow
If .Cells(iRow + 1, cMZ).Value = .Cells(iRow, cMZ).Value Then
iEnd = iEnd + 1
Else
If iStart <> iEnd Then Call CheckData2(iStart, iEnd)
iStart = iRow + 1
iEnd = iStart
End If
Next iRow
End With
On Error Resume Next
rData.Columns(cMZ).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0
'---------------------------------------------------------------------------
'pass #3 - for a MZ with 2+ rows, delete if
' a HC outside
iStart = 2
iEnd = iStart
With rData
For iRow = 2 To .Rows.Count
Application.StatusBar = "Pass #3 - Row " & iRow
If .Cells(iRow + 1, cMZ).Value = .Cells(iRow, cMZ).Value Then
iEnd = iEnd + 1
Else
If iStart <> iEnd Then Call CheckData3(iStart, iEnd)
iStart = iRow + 1
iEnd = iStart
End If
Next iRow
End With
On Error Resume Next
rData.Columns(cMZ).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0
'---------------------------------------------------------------------------
'pass #4 - for a MZ with 2+ rows, delete
' a not the largest HC
iStart = 2
iEnd = iStart
With rData
For iRow = 2 To .Rows.Count
Application.StatusBar = "Pass #4 - Row " & iRow
If .Cells(iRow + 1, cMZ).Value = .Cells(iRow, cMZ).Value Then
iEnd = iEnd + 1
Else
If iStart <> iEnd Then Call CheckData4(iStart, iEnd)
iStart = iRow + 1
iEnd = iStart
End If
Next iRow
End With
On Error Resume Next
rData.Columns(cMZ).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0
'---------------------------------------------------------------------------
'pass #5 - tiebreaker
'1.) If the value within the "P" column of the duplicates is a non-zero digit, then the duplicate must contain a H/C value
' within the range: 1.5 <= # <= 2.25
' (if the duplicate has a zero in the “P” column, then void the tiebreaker #1 and move straight to tiebreaker #2).
'
' 2.) Keep the duplicate that has the value closest to zero within the "stddev2" column.
'
' if there are still duplicates that passed tiebreaker #1 or jumped straight to tiebreaker #2, and
' they have the same "stddev2" value as well, then completely delete all of the duplicates
iStart = 2
iEnd = iStart
With rData
For iRow = 2 To .Rows.Count
Application.StatusBar = "Pass #5 - Row " & iRow
If .Cells(iRow + 1, cMZ).Value = .Cells(iRow, cMZ).Value Then
iEnd = iEnd + 1
Else
If iStart <> iEnd Then Call CheckData5(iStart, iEnd)
iStart = iRow + 1
iEnd = iStart
End If
Next iRow
End With
On Error Resume Next
rData.Columns(cMZ).SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
On Error GoTo 0
Application.StatusBar = False
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
'--------------------------------------------------------------------
Private Function RowIsMarked(i As Long) As Boolean
RowIsMarked = Application.WorksheetFunction.IsLogical(rData.Cells(i, cMZ).Value)
End Function
Private Sub MarkRow(i As Long)
rData.Cells(i, cMZ).Value = True
End Sub
Private Function NO_Outside(i As Long) As Boolean
NO_Outside = rData.Cells(i, cNO).Value > 2#
End Function
Private Function NSO_Outside(i As Long) As Boolean
NSO_Outside = rData.Cells(i, cNSO).Value > 1#
End Function
Private Function HC_Outside(i As Long) As Boolean
HC_Outside = rData.Cells(i, cHC).Value > 2.25
End Function
Private Function All_NO_Outside(S As Long, E As Long) As Boolean
Dim i As Long
All_NO_Outside = True
For i = S To E
If Not NO_Outside(i) Then
All_NO_Outside = False
Exit Function
End If
Next i
End Function
Private Function All_NSO_Outside(S As Long, E As Long) As Boolean
Dim i As Long
All_NSO_Outside = True
For i = S To E
If Not NSO_Outside(i) Then
All_NSO_Outside = False
Exit Function
End If
Next i
End Function
'------------------------------------------------------------------------
Private Sub CheckData1(S As Long, E As Long)
Dim i As Long
With rData
For i = S To E
If NO_Outside(i) And NSO_Outside(i) Then MarkRow (i)
Next i
End With
End Sub
'any NO outside
Private Sub CheckData2(S As Long, E As Long)
Dim i As Long
Dim bAllRowsOutside As Boolean
With rData
For i = S To E
If NSO_Outside(i) And Not NO_Outside(i) Then
MarkRow (i)
ElseIf Not NSO_Outside(i) And NO_Outside(i) Then
MarkRow (i)
End If
Next i
bAllRowsOutside = True
For i = S To E
If Not (NSO_Outside(i) And NO_Outside(i)) Then
bAllRowsOutside = False
Exit For
End If
Next i
If bAllRowsOutside Then
For i = S To E
MarkRow (i)
Next i
End If
End With
End Sub
Private Sub CheckData3(S As Long, E As Long)
Dim i As Long
With rData
For i = S To E
If HC_Outside(i) Then MarkRow (i)
Next i
End With
End Sub
Private Sub CheckData4(S As Long, E As Long)
Dim i As Long
Dim m As Double
With rData
m = 0#
For i = S To E
If .Cells(i, cHC).Value > m Then m = .Cells(i, cHC).Value
Next i
For i = S To E
If .Cells(i, cHC).Value < m Then MarkRow (i)
Next i
End With
End Sub
Private Sub CheckData5(S As Long, E As Long)
Dim i As Long, j As Long, n As Long, n1 As LoadPictureConstants
Dim m As Double
If S = E Then Exit Sub
n = E - S + 1
With rData
For i = S To E
If .Cells(i, cP).Value <> 0# Then
For j = S To E
If .Cells(j, cP).Value <> 0# Then
If (.Cells(j, cHC).Value < 1.5) Or (.Cells(j, cHC).Value > 2.25) Then
.Cells(j, cMZ).Value = True
n = n - 1
End If
End If
Next j
End If
Next i
If n = 1 Then Exit Sub
m = 10 ^ 6
For i = S To E
If Not Application.WorksheetFunction.IsLogical(.Cells(i, cMZ).Value) Then
If Abs(.Cells(i, cStdDev2).Value) < m Then m = Abs(.Cells(i, cStdDev2).Value)
End If
Next i
n1 = 0
For i = S To E
If Not Application.WorksheetFunction.IsLogical(.Cells(i, cMZ).Value) Then
If Abs(.Cells(i, cStdDev2).Value) = m Then n1 = n1 + 1
End If
Next i
If n1 = 1 Then
For i = S To E
If Not Application.WorksheetFunction.IsLogical(.Cells(i, cMZ).Value) Then
If Abs(.Cells(i, cStdDev2).Value) <> m Then
.Cells(i, cMZ).Value = True
End If
End If
Next i
Else
For i = S To E
.Cells(i, cMZ).Value = True
Next i
End If
End With
End Sub
Reply With Quote