countif usage ?

[Guest]

Hi I would like to find out if countif can be used delete all the rows, I
mean If there are 4 rows in a sheet with same First and Last Name I like to
be able to delete all the 4 rows instead of just 3 as this current script
does ? Any thoughts ?

Dim Col As Integer
Dim r As Long
Dim C As Range
Dim N As Long
Dim V As Variant
Dim S As Variant
Dim Rng As Range
Dim strName As String, _
strFNameCol As String, _
strLNameCol As String

strFNameCol = TxtFNCol.Value
strLNameCol = TxtLNCol.Value

On Error GoTo EndMacro
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Col = ActiveCell.Column

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

N = 0
For r = Rng.Rows.Count To 1 Step -1
V = Rng.Cells(r, strFNameCol).Value
S = Rng.Cells(r, strLNameCol).Value
If Application.WorksheetFunction.CountIf(Rng.Columns(strFNameCol), V) >
1 And _
Application.WorksheetFunction.CountIf(Rng.Columns(strLNameCol), S) >
1 Then
Rng.Rows(r).EntireRow.Delete
N = N + 1
End If
Next r

EndMacro:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End_of_Data:
MsgBox "Data Extracted"

THX

 

[Tom Ogilvy]

for a start, your code doesn't work correctly as written

If you had

Jones Ralph
Smith Mike
Jones Mike

then Jones Mike would be deleted.

That doesn't appear to be your intent - and that may not be a possibility
with your data, but it is usually a bad idea to use a flawed algorithm.

I think the easiest would be to use a dummy column to the right of your
data, using a counting function and delete any rows that met the critieria
of not being unique.

=sumproduct(--($F$1:$F$200=$F1),--($L$1:$L$200=$L1))

would give you the count of duplicates for that row.

Sub Tester2()
Dim Col As Range
Dim colF As Range
Dim colL As Range
Dim Rng As Range
Dim strName As String, _
strFNameCol As String, _
strLNameCol As String

strFNameCol = TxtFNCol.Value
strLNameCol = TxtLNCol.Value

'On Error GoTo EndMacro
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

Set Col = Rng.Offset(, Rng.Columns.Count).Resize(, 1).Cells
Set colF = Intersect(Rng, Columns(strFNameCol & ":" & strFNameCol)).Cells
Set colL = Intersect(Rng, Columns(strLNameCol & ":" & strLNameCol)).Cells
Col.Formula = "=if(Sumproduct(--(" & colF.Address & "=" & colF(1).Address(0,
1) _
& "),--(" & colL.Address & "=" & colL(1).Address(0, 1) &
"))>1,na(),"""")"
On Error Resume Next
Col.SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
Col.ClearContents


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End_of_Data:
MsgBox "Data Extracted"
End Sub

 

[Tom Ogilvy]

The previous version assumed empty columns to the right, but since you
include the provision to perform this on a selection, this version inserts a
column (so at least column IV must be empty) and places the formula there,
then deletes it when done (so any data to the right of the selection won't
be disturbed except for the rows deleted).

Sub Tester2()
Dim Col As Range
Dim colF As Range
Dim colL As Range
Dim Rng As Range
Dim strName As String, _
strFNameCol As String, _
strLNameCol As String

strFNameCol = TxtFNCol.Value
strLNameCol = TxtLNCol.Value


'On Error GoTo EndMacro
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

Rng(1).Offset(0, Rng.Columns.Count).EntireColumn.Insert
Set Col = Rng.Offset(, Rng.Columns.Count).Resize(, 1).Cells
Set colF = Intersect(Rng, Columns(strFNameCol & ":" & strFNameCol)).Cells
Set colL = Intersect(Rng, Columns(strLNameCol & ":" & strLNameCol)).Cells
Col.Formula = "=if(Sumproduct(--(" & colF.Address & "=" & colF(1).Address(0,
1) _
& "),--(" & colL.Address & "=" & colL(1).Address(0, 1) &
"))>1,na(),"""")"
On Error Resume Next
Col.SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
Col.EntireColumn.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End_of_Data:
MsgBox "Data Extracted"
End Sub

 

[Guest]

Thanks, This improves the speed aswell.

The previous version assumed empty columns to the right, but since you
include the provision to perform this on a selection, this version inserts a
column (so at least column IV must be empty) and places the formula there,
then deletes it when done (so any data to the right of the selection won't
be disturbed except for the rows deleted).

Sub Tester2()
Dim Col As Range
Dim colF As Range
Dim colL As Range
Dim Rng As Range
Dim strName As String, _
strFNameCol As String, _
strLNameCol As String

strFNameCol = TxtFNCol.Value
strLNameCol = TxtLNCol.Value


'On Error GoTo EndMacro
'Application.ScreenUpdating = False
'Application.Calculation = xlCalculationManual

If Selection.Rows.Count > 1 Then
Set Rng = Selection
Else
Set Rng = ActiveSheet.UsedRange.Rows
End If

Rng(1).Offset(0, Rng.Columns.Count).EntireColumn.Insert
Set Col = Rng.Offset(, Rng.Columns.Count).Resize(, 1).Cells
Set colF = Intersect(Rng, Columns(strFNameCol & ":" & strFNameCol)).Cells
Set colL = Intersect(Rng, Columns(strLNameCol & ":" & strLNameCol)).Cells
Col.Formula = "=if(Sumproduct(--(" & colF.Address & "=" & colF(1).Address(0,
1) _
& "),--(" & colL.Address & "=" & colL(1).Address(0, 1) &
"))>1,na(),"""")"
On Error Resume Next
Col.SpecialCells(xlFormulas, xlErrors).EntireRow.Delete
On Error GoTo 0
Col.EntireColumn.Delete

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End_of_Data:
MsgBox "Data Extracted"
End Sub