Delete Duplicate Rows

[Mark F]

Hi Guys

I have tried to search Mr Excel and can't quite find what I am looking for. I have tried a few examples that haven't worked for whatever reason - me probably

I have a sheet that has around 58000 rows with 5 columns.

I need to delete all of the duplicates of rows where there is a duplication in column C - in other words leaving just one entry of that row

This is a one off job so the number of rows is fixed as such

There are no blanks in any other 5 columns

Thanks for any help

Mark[/img]

 

[Mark F]

By the way it took around 2and a half minutes for Tom's Macro to work through in full

Mark

 

[nisht]

Sorry Black Head that my code didnot performed the way i epected.

I did knew that it can take lot of time by looping so not the best way to go when advance filter can do the job.

I also suggest you to try yogis way i think it is more optimized only thing is that first you need to make copy of your spread sheet...

and yes TOM is alway best..is see his postings.. always to learn.

 

[NateO]

Hello again,

The following took ~1.01 minutes to run on a really crappy laptop with 58,000 rows of data.

I grabbed three columns of 6, asking that the third, Col2 be unique.

I started with:

Ex to Ex.xls
	A	B	C	D	E	F
1	col1	col2	col3	col4	col5	col6
2	21	22	23	24	25	26
3	test1	32	33	34	35	36
4	41	42	43	44	45	46
5	51	52	53	54	55	56
6	61	62	63	64	65	66
Sheet1

Ended up with:

Ex to Ex.xls
	A	B	C	D
1	Col1	Col4	Col2
2	100001	100004	100002
3	100011	100014	100012
4	10001	10004	10002
5	100021	100024	100022
6	100031	100034	100032
Sheet2

Here's the code:<font face=Courier New><SPAN style="color:darkblue">Sub</SPAN> NoDups()<SPAN style="color:darkblue">Dim</SPAN> cn<SPAN style="color:darkblue">As</SPAN><SPAN style="color:darkblue">Object</SPAN>, rs<SPAN style="color:darkblue">As</SPAN><SPAN style="color:darkblue">Object</SPAN><SPAN style="color:darkblue">Dim</SPAN> clcMde<SPAN style="color:darkblue">As</SPAN><SPAN style="color:darkblue">Long</SPAN>

clcMde = Application.Calculation
Application.ScreenUpdating =<SPAN style="color:darkblue">False</SPAN>
Application.Calculation = xlCalculationManual<SPAN style="color:darkblue">Set</SPAN> cn = CreateObject("ADODB.Connection")

cn.<SPAN style="color:darkblue">Open</SPAN> "Provider=Microsoft.Jet.OLEDB.4.0; Data Source=" & _
    ThisWorkbook.FullName & ";Extended Properties=Excel 8.0;"  <SPAN style="color:green">'Create DB connection</SPAN>
    <SPAN style="color:darkblue">Set</SPAN> rs = CreateObject("ADODB.Recordset")<SPAN style="color:darkblue">With</SPAN> rs
    <SPAN style="color:darkblue">Set</SPAN> .ActiveConnection = cn
    .Source = "Select min(col1), min(col4), col2 " & _
        "From [Sheet1$a1:f58000] Group By col2"<SPAN style="color:green">'Pass your SQL</SPAN>
    .<SPAN style="color:darkblue">Open</SPAN> , , 3, 3  <SPAN style="color:green">'.Open , , adOpenStatic, adLockOptimistic</SPAN>
    Sheets(2).[a2].CopyFromRecordset rs
    .<SPAN style="color:darkblue">Close</SPAN><SPAN style="color:darkblue">End</SPAN><SPAN style="color:darkblue">With</SPAN>
cn.<SPAN style="color:darkblue">Close</SPAN><SPAN style="color:darkblue">Set</SPAN> rs = Nothing:<SPAN style="color:darkblue">Set</SPAN> cn =<SPAN style="color:darkblue">Nothing</SPAN>

Application.Calculation = clcMde
Application.ScreenUpdating =<SPAN style="color:darkblue">True</SPAN><SPAN style="color:darkblue">End</SPAN><SPAN style="color:darkblue">Sub</SPAN></FONT>

You just want to have column headers in your source sheet, the rest is gravy eh.

 

[Trag]

This should also work, note however, as MyRng becomes very large, setting the union becomes bollox slow:

<font face=Courier New><SPAN style="color:darkblue">Sub</SPAN> Dude_Yer_Gittin_A_Del()
<SPAN style="color:darkblue">Dim</SPAN> Uni <SPAN style="color:darkblue">As</SPAN> <SPAN style="color:darkblue">New</SPAN> Collection, cl <SPAN style="color:darkblue">As</SPAN> Range, myRng <SPAN style="color:darkblue">As</SPAN> Range
Application.ScreenUpdating = <SPAN style="color:darkblue">False</SPAN>
<SPAN style="color:darkblue">On</SPAN> <SPAN style="color:darkblue">Error</SPAN> <SPAN style="color:darkblue">Resume</SPAN> <SPAN style="color:darkblue">Next</SPAN>

<SPAN style="color:darkblue">For</SPAN> <SPAN style="color:darkblue">Each</SPAN> cl <SPAN style="color:darkblue">In</SPAN> Range([c1], [c65536].End(3))
    Uni.Add cl.Value, <SPAN style="color:darkblue">CStr</SPAN>(cl.Value)
    <SPAN style="color:darkblue">If</SPAN> Err.Number <> 0 <SPAN style="color:darkblue">Then</SPAN>
        Err.Clear
        <SPAN style="color:darkblue">If</SPAN> myRng <SPAN style="color:darkblue">Is</SPAN> <SPAN style="color:darkblue">Nothing</SPAN> <SPAN style="color:darkblue">Then</SPAN> <SPAN style="color:darkblue">Set</SPAN> myRng = cl Else _
            <SPAN style="color:darkblue">Set</SPAN> myRng = Union(cl, myRng)
    <SPAN style="color:darkblue">End</SPAN> <SPAN style="color:darkblue">If</SPAN>
<SPAN style="color:darkblue">Next</SPAN> cl

<SPAN style="color:darkblue">Set</SPAN> Uni = <SPAN style="color:darkblue">Nothing</SPAN>
myRng.EntireRow.Delete

Application.ScreenUpdating = <SPAN style="color:darkblue">True</SPAN>
<SPAN style="color:darkblue">End</SPAN> <SPAN style="color:darkblue">Sub</SPAN></FONT>

I didn't necessarily want to write this as such, but a different line of logic, which seemed much better, wasn't working as I expected it to...

I've recently had my pc go through an upgrade on its operating system here at work and this code (above) used to work wonderfully before the upgrade to WinXP but not the code can't run because I get a compile error; "Can't find project or library".

The code breaks at "[A1]" in the code below.

For Each Al In Range([A1], [A65536].End(3))

Does anyone know a work around or the library I'd need to help run this code?

Here is my complete code (I've made the adjustment for Nate's code to look in column A instead of C)...

Private Sub Sort_Click()
Application.ScreenUpdating = False
Range("F2").Select
ActiveCell.FormulaR1C1 = "=RC[-5]*1"
Range("F2").Copy
Range("F15000").Select
Range("F2:F15000").Select
Range("F15000").Activate
Range("F2:F15000").Select
Range("F15000").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Copy
Range("A2").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns("F:F").Select
Application.CutCopyMode = False
Selection.ClearContents
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("B2").Select
ActiveCell.FormulaR1C1 = "0"
Range("C2").Select
ActiveCell.FormulaR1C1 = "0"
Range("D2").Select
ActiveCell.FormulaR1C1 = "0"
Range("E2").Select
ActiveCell.FormulaR1C1 = "0"
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1").Select
ActiveCell.FormulaR1C1 = "SKU_CD"
Range("B1").Select
ActiveCell.FormulaR1C1 = "SKU_DESC"
Range("C1").Select
ActiveCell.FormulaR1C1 = "SKU_ANALYSIS"
Range("D1").Select
ActiveCell.FormulaR1C1 = "NVTY_LOCATION"

Dim Uni As New Collection, Al As Range, myRng As Range
On Error Resume Next

For Each Al In Range([A1], [A65536].End(3))
Uni.Add Al.Value, CStr(Al.Value)
If Err.Number <> 0 Then
Err.Clear
If myRng Is Nothing Then Set myRng = Al Else _
Set myRng = Union(Al, myRng)
End If
Next Al

Set Uni = Nothing
myRng.EntireRow.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
ActiveCell.FormulaR1C1 = "0"
Range("B1").Select
ActiveCell.FormulaR1C1 = "0"
Range("C1").Select
ActiveCell.FormulaR1C1 = "0"
Range("D1").Select
ActiveCell.FormulaR1C1 = "0"
Range("E1").Select
ActiveCell.FormulaR1C1 = "0"
Range("F1").Select
Columns("A:E").Copy
Sheets("Catalogue").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A1").Select
Sheets("Sku Importer").Select
Application.CutCopyMode = False
Selection.ClearContents
Range("A1").Select
Application.ScreenUpdating = True
End Sub

~Trag

 

[NateO]

Odd, I've used the Evaluate method in XP, in any case, try changing:

For Each Al In Range([A1], [A65536].End(3))

to

For Each Al In Range(Range("A1"), Range("A65536").End(xlUp))

 

[Trag]

YES!!! Good job Nate! You rock!


Thanks!!
~Trag

 

[NateO]

You are welcome. Best to your Canucks eh.

 

[just_jon]

Hmmm... I use that failed syntax a lot -- was it the eval or the numeric argument that was at fault, or both? [Don't want to send out stuff that might not work on the receiving machine.]

 

[NateO]

You've got me Jon, I just tried:

For Each cl In Range([A1], [A65536].End(3))

and

msgbox [a65536].end(3).address

In XP and they both worked fine.

 

[Legacy 21301]

In the VBE go to Tools>References and check whether there is anything marked as MISSING.
If so, clear the check box and then try running the "evaluate method" code (the square-brackets code).

MSKB has a number of articles about various scenarios that can cause "Can't find project or library".