Delete duplicates (based on the same line multiple columns)

[elsg]

I'm trying to have a unique code to delete duplicates.


unfortunately what I got was just having two routines to delete duplicate rows.

I try make something based link above, but i can't it
http://www.vbaexpress.com/forum/showthread.php?10600-Solved-Delete-Duplicate-Rows-based-on-multiple-columns

Option Explicit
Sub DeleteDups()
Dim ws1 As Worksheet
Dim lrws1 As Long, i As Long
Call TipFormula '<- secondth code
Set ws1 = Sheets("Plan3")
Application.ScreenUpdating = 0
lrws1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row


For i = 2 To lrws1
ws1.UsedRange.AutoFilter Field:=8, Criteria1:="Duplicate"
ws1.UsedRange.Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
Next i
ws1.AutoFilterMode = False
Application.ScreenUpdating = 1
End Sub
Secondth code

Sub TipFormula()
Dim lr As Long
'Application.ScreenUpdating = False
Const sFormula1 As String = "=IF(SUM(COUNTIF($B2:$G2,B2)>1,COUNTIF($B2:$G2,C2)>1,COUNTIF($B2:$G2,D2)>1,COUNTIF($B2:$G2,E2)>1,COUNTIF($B2:$G2,F2)>1,COUNTIF($B2:$G2,G2)>1),""Duplicate"","""")"

With Sheets("Plan3")
lr = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Range("H2").FormulaArray = sFormula1
.Range("H2").AutoFill .Range("H2").Resize(lr - 1)
.Range("H2").Resize(lr, 8).Value = .Range("H2").Resize(lr, 8).Value
End With
'Application.ScreenUpdating = True

End S

[SamT]

Maybe this will work for you. It is tested on the example book you gave.


Sub DeleteDups()
Dim ws1 As Worksheet
Dim Cel As Range
Dim Dup As Range
Dim lrws1 As Long, i As Long
'Call TipFormula '<- secondth code
Set ws1 = Sheets("Plan3")

Application.ScreenUpdating = 0
ws1.AutoFilterMode = False

lrws1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row

With ws1
For i = 2 To lrws1
For Each Cel In .Rows(i).Range("B1:G1")
If Cel.Value <> "" Then
Set Dup = .Rows(i).Find(Cel.Value, Cel)
Do While Dup.Address <> Cel.Address
Dup.Value = ""
Set Dup = .Rows(i).FindNext(Dup)
Loop
End If
Next Cel
Next i
End With

Application.ScreenUpdating = 1
End Sub

[snb]

Sub M_snb()
For Each cl In Plan3.Cells(1).CurrentRegion.SpecialCells(2, 1)
c00 = cl.Value
Plan3.Cells(1).CurrentRegion.Replace cl, ""
cl.Value = c00
Next
End Sub

[snb]

crossposted:

http://www.mrexcel.com/forum/excel-questions/746469-compare-same-row-several-columns-duplicate-data.html

[elsg]

I need delete rows!

thank you!!

[SamT]

What criteria to delete a row?

[elsg]

hi SamT, I trying make only one code.


Sub DeleteDups() + Sub TipFormula()=uniqCode

Thank you!!

[SamT]

You say you need to delete Dups. My code in post #2 does delete Dups (on each Row).

You say you need to delete Rows.

What do you really need?

We will get the Delete(Rows OR Dups) fixed first. Then fix TipFormula. OK?

Please make new example. One Workbook with two sheets:


Sheet/Tab Named "Existing" with all existing rows and cells.Use Color to show what to delete.
Sheet/Tab Named "Desired" same As "Existing" Sheet after deleting as you want.

[elsg]

I need delete rows (my codes make it), but there some criterias.

I want to join both codes

Thank you!

[SamT]

Please make new example. One Workbook with two sheets:



Sheet/Tab Named "Existing" with all existing rows and cells.Use Color to show what to delete.
Sheet/Tab Named "Desired" same As "Existing" Sheet after deleting as you want.

[elsg]

look my file.

thank you!!:thumb

[Trebor76]

Hi elsg,

Let us know how this goes:


Option ExplicitSub Macro1()


'Written by Trebor76
'Visit my website www.excelguru.net.au

'From Row 2, delete any row where the entries in Col's B to Col. G (inclusive) are not all unique.

Dim lngMyCol As Long, _
lngMyRow As Long
Dim xlnCalcMethod As XlCalculation

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

lngMyCol = Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
lngMyRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

With Columns(lngMyCol)
With Range(Cells(2, lngMyCol), Cells(lngMyRow, lngMyCol)) 'Starts from Row 2. Change to suit.
.Formula = "=IF(MAX(FREQUENCY(B2:G2,B2:G2))>1,NA(),"""")"
ActiveSheet.Calculate
.Value = .Value
End With
On Error Resume Next 'Turn error reporting off - OK to ignore 'No cells found' message
.SpecialCells(xlCellTypeConstants).EntireRow.Delete
On Error GoTo 0 'Turn error reporting back on
.Delete
End With

With Application
.Calculation = xlnCalcMethod
.ScreenUpdating = True
End With


MsgBox "All applicable rows have now been deleted.", vbInformation, "Excel Guru"


End Sub

Regards,

Robert

[elsg]

Perfect!!!!

Thank you very mauch!!!

[Trebor76]

Thanks for letting us know (and adding to my reputation) and you're welcome ;)