delete single occurances in a string

[J.W. Aldridge]

i have headers in a5:g5
I have data in columns A6:G5000.

based on the series of numbers in column b, i want to delete all
single occurances of the number found.

In other words, if it is not listed/found in column B at least twice,
delete the entire row.

 

[Dave Peterson]

I would add a new column C (just temporarily).

Then in C6, I'd add this formula:
=if(countif($b$6:$b$5000,b6)>1,"ok",na())
and drag down.

This would result in an error on every row that had exactly one occurrence.

Then I'd select that range
convert to values (to remove the slow calculation)
Edit|goto|special|constants and errors
delete those selected rows
delete column C.

In code:

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim myRng As Range

Set wks = Worksheets("Sheet1")

With wks

Set myRng = .Range("B5:B5000")

myRng.Cells(1).Offset(0, 1).EntireColumn.Insert

With myRng.Offset(0, 1)
.Formula = "=if(countif(" & myRng.Address & "," _
& myRng.Cells(1).Address(0, 0) & ")>1,""ok"",na())"
.Value = .Value
End With

On Error Resume Next 'in case there are no errors
myRng.Offset(0, 1).Cells.SpecialCells(xlCellTypeConstants, xlErrors) _
.EntireRow.Delete
On Error GoTo 0

'remove the helper column
myRng.Cells(1).Offset(0, 1).EntireColumn.Delete

End With

End Sub

 

[Rick Rothstein]

I think this macro should do what you want (just change the example
worksheet name I used in the With statement to your actual worksheet's
name)...

Sub DeleteSingleEntriesInColumnB()
Dim X As Long, LastRow As Long, U As Range
Const FirstRow As Long = 6
With Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
For X = FirstRow To LastRow
If WorksheetFunction.CountIf(.Range("B" & FirstRow & _
":B" & LastRow), .Cells(X, "B")) = 1 Then
If U Is Nothing Then
Set U = .Rows(X)
Else
Set U = Union(U, .Rows(X))
End If
End If
Next
End With
U.Delete
End Sub

 

[J.W. Aldridge]

Thanx...

Works perfectly.

Only thing is...

If I wanted to change the worksheets to the current/ active sheet...

Set wks = Worksheets("Sheet1")

 

[Rick Rothstein]

Just replace Worksheets("Sheet1") with ActiveSheet and that should do it.

You can do this with the code I post also in case you want to try it out (my
code does not insert/delete any columns... it just works with the data you
have).