PDA

View Full Version : [SOLVED:] Delete duplicates (based on the same line multiple columns)



elsg
12-21-2013, 03:06 PM
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
12-22-2013, 09:26 AM
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
12-22-2013, 09:51 AM
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
12-22-2013, 02:52 PM
crossposted:

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

elsg
12-22-2013, 06:30 PM
I need delete rows!

thank you!!

SamT
12-23-2013, 10:39 AM
What criteria to delete a row?

elsg
12-23-2013, 11:47 AM
hi SamT, I trying make only one code.


Sub DeleteDups() + Sub TipFormula()=uniqCode

Thank you!!

SamT
12-24-2013, 12:30 PM
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
12-24-2013, 01:45 PM
I need delete rows (my codes make it), but there some criterias.

I want to join both codes

Thank you!

SamT
12-25-2013, 09:12 AM
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
12-26-2013, 03:00 PM
look my file.

thank you!!:thumb

Trebor76
12-26-2013, 04:15 PM
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
12-26-2013, 05:09 PM
Perfect!!!!

Thank you very mauch!!!

Trebor76
12-26-2013, 06:34 PM
Thanks for letting us know (and adding to my reputation) and you're welcome ;)