Deleting Duplicates Macro
 

Cells A1:L1 have contents in them. I want to create a code so that if these
same contents appear again in any row between A2:L200 that row will be
deleted. Any thoughts?

Deleting Duplicates Macro
 

Hi

This should cover it for you.

take care

Marcus

Sub FindandDel()
Dim rgFoundCell As Range
Dim strFindMe As String
Dim i As Long
'Handles columns A to L
For i = 1 To 12
strFindMe = Cells(1, i).Value
Application.ScreenUpdating = False
With Sheet1 'Change sheet name to appropriate, also range A2:L200
Set rgFoundCell = .Range("A2:L200").Find(what:=strFindMe)
Do Until rgFoundCell Is Nothing
rgFoundCell.EntireRow.Delete
Set rgFoundCell = .Range("A2:L200").FindNext
Loop
End With
Next i

Application.ScreenUpdating = True

End Sub

Deleting Duplicates Macro
 

Hi Marcus,

Thank you for your input. I added your code to the one I already had. For
some reason after the orginal steps were completed the macro stopped and an
hour glass came up. I also tried the code by itself and the same thing
happened with the hour glass. In both cases I let the hour glass go for a
couple minutes but nothing happened so I ended the program because it locked
up. I am not sure if it's something I did incorrectly. Below are the two
codes that I tried.

Code #1
Rows("1:3").Select
Selection.Delete Shift:=xlUp
Range("A1").Select
ActiveCell.FormulaR1C1 = "Order Type"
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
Columns("O:O").Select
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Range("M1").Select
ActiveCell.FormulaR1C1 = "Part Number"
Columns("M:M").Select
Selection.Cut
Columns("I:I").Select
Selection.Insert Shift:=xlToRight
Columns("N:N").Select
Selection.Cut
Columns("J:J").Select
Selection.Insert Shift:=xlToRight
Columns("L:O").Select
Selection.Delete Shift:=xlToLeft
Columns("M:P").Select
Selection.Delete Shift:=xlToLeft
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

Firstrow = ActiveSheet.UsedRange.Cells(1).Row
Lastrow = ActiveSheet.UsedRange.Rows.Count + Firstrow - 1
With ActiveSheet
.DisplayPageBreaks = False
For Lrow = Lastrow To Firstrow Step -1
If Application.CountA(.Range(.Cells(Lrow, "A"), .Cells(Lrow,
"L"))) = 0 Then .Rows(Lrow).Delete
Next
End With
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With

Dim rgFoundCell As Range
Dim strFindMe As String
Dim i As Long
'Handles columns A to L
For i = 1 To 12
strFindMe = Cells(1, i).Value
Application.ScreenUpdating = False
With Sheet1 'Change sheet name to appropriate, also range A2:L200
Set rgFoundCell = .Range("A2:L200").Find(what:=strFindMe)
Do Until rgFoundCell Is Nothing
rgFoundCell.EntireRow.Delete
Set rgFoundCell = .Range("A2:L200").FindNext
Loop
End With
Next i

Application.ScreenUpdating = True

End Sub

Code # 2

Sub FindandDel()
Dim rgFoundCell As Range
Dim strFindMe As String
Dim i As Long
'Handles columns A to L
For i = 1 To 12
strFindMe = Cells(1, i).Value
Application.ScreenUpdating = False
With Sheet1 'Change sheet name to appropriate, also range A2:L200
Set rgFoundCell = .Range("A2:L200").Find(what:=strFindMe)
Do Until rgFoundCell Is Nothing
rgFoundCell.EntireRow.Delete
Set rgFoundCell = .Range("A2:L200").FindNext
Loop
End With
Next i

Application.ScreenUpdating = True

End Sub



"marcus" wrote:

Hi

This should cover it for you.

take care

Marcus

Sub FindandDel()
Dim rgFoundCell As Range
Dim strFindMe As String
Dim i As Long
'Handles columns A to L
For i = 1 To 12
strFindMe = Cells(1, i).Value
Application.ScreenUpdating = False
With Sheet1 'Change sheet name to appropriate, also range A2:L200
Set rgFoundCell = .Range("A2:L200").Find(what:=strFindMe)
Do Until rgFoundCell Is Nothing
rgFoundCell.EntireRow.Delete
Set rgFoundCell = .Range("A2:L200").FindNext
Loop
End With
Next i

Application.ScreenUpdating = True

End Sub