Deleting rows A to E when finding dublicated Data in Column B

  • Thread starter Thread starter bkbri
  • Start date Start date
B

bkbri

Hello,

Could someone please help me agian. I'm trying to get a Macro that wil
search through my spread sheet and when it finds a dublicated tex
entry in column B it will delete everything from A to E


__A___B___C___D___E
1.| T | P | A | C | W
2.| B | P | S | A | J <--- Dublicate P found Deleting A to E
3.| A | Y | N | L | Q
4.| D | E | X | E | I
5.| V | N | Z | F | U

And so on...

Thanks,
Bria
 
Sub Tester9()
Dim rng As Range, rng1 As Range
Dim rng3 As Range
With ActiveSheet
Set rng3 = .Range(Range("A1"), .UsedRange)
.Columns(3).Insert
rng3.Columns(3).Formula = _
"=If(Countif($B$1:B1,B1)>1,NA())"
On Error Resume Next
Set rng = .Columns(3).SpecialCells(xlFormulas, xlErrors)
On Error GoTo 0
If Not rng Is Nothing Then
Set rng1 = Intersect(rng.EntireRow, Range("A:F"))
rng1.Select
rng1.Delete Shift:=xlShiftUp
End If
.Columns(3).Delete
End With
End Sub
 
Option Explicit

Sub DelDuplic()
Dim i As Long, j As Long
Dim strCurr As String, strNext As String

i = 1
j = i + 1

Do While Not IsEmpty(ThisWorkbook.Worksheets("2").Range
("B" & i)) _
And Not IsEmpty(ThisWorkbook.Worksheets("2").Range
("B" & j))
strCurr = ThisWorkbook.Worksheets("2").Range("B" & i)
strNext = ThisWorkbook.Worksheets("2").Range("B" & j)
If strCurr = strNext Then
ThisWorkbook.Worksheets("2").Range(j & ":" &
j).Delete
i = i - 1
End If
i = i + 1
j = i + 1
Loop

End Sub
 
Hi Tom,

Just tried your Macro and it doesnt work. What happens is it highlight
all rows that it finds with dublicated text in column b then pushe
c,d,e over 1 and creates its own column in C and adds #N/A besid
column B dublicates and the rest it adds FALSE.

After that my Excel program hangs. Im using Excel 2002.

The way I added in your Macro is I went to tools, macro, visual basi
editor, insert, module. Are these steps correct Im a newbie.

Thanks,
Bria
 
That is what it does, but then it deletes those rows containing #NA (which
are the duplicates) and removed the inserted column C so you data is back
the way you had it.

I can't say why it is hanging in your situation. I copied it from a general
module where it was working fine for me.

you can remove the

rng1.Select

that is left over from when I was testing it, but that would only stop the
highlighting of the rows to be deleted.

I tested it with 9000 rows, about 8950 to be delete and it took 114 seconds
using this version.

Sub Tester9()
Dim dStart As Double
dStart = Timer
Application.Calculation = xlManual
Dim rng As Range, rng1 As Range
Dim rng3 As Range
With ActiveSheet
Set rng3 = .Range(Range("A1"), .UsedRange)
.Columns(3).Insert
rng3.Columns(3).Formula = _
"=If(Countif($B$1:B1,B1)>1,NA())"
rng3.Columns(3).Formula = rng3.Columns(3).Value
On Error Resume Next
Set rng = .Columns(3).SpecialCells(xlConstants, xlErrors)
On Error GoTo 0
If Not rng Is Nothing Then
Set rng1 = Intersect(rng.EntireRow, Range("A:F"))
rng1.Select
rng1.Delete Shift:=xlShiftUp
End If
.Columns(3).Delete
End With
Application.Calculation = xlAutomatic
Debug.Print Timer - dStart
End Sub

Are you sure it is hung or it it just working.
 
Okay thanks Tom I'll try it agian.

Does there have to be 5 columns. I tried it on a spreadsheet that ha
A, B columns filled in with Data with about 4000 rows. It highlighte
the duplicate entries and filled in column C with FALSE,#N/A and jus
sat there.

I'll wait a little longer this time.

I hope it works and thanks agian,
Bria
 
Tom,

Thanks so much it worked perfect this time. I used your new version it
was very fast.

Man I wish I had a brain like yours.

Thanks agian,
Brian
 
Back
Top