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/show...ltiple-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-q...cate-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:

1. Sheet/Tab Named "Existing" with all existing rows and cells.Use Color to show what to delete.
2. 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:

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

[elsg]

look my file.

thank you!!

[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