Solved: reduce size of macro

[nicko]

hi all,

I have the following macro, which clears duplicate entries in column C...


Sub clearDupsC()
Dim x As Long
Dim LastRow As Long
LastRow = Range("c65536").End(xlUp).Row
For x = LastRow To 1 Step -1
If Application.WorksheetFunction.CountIf(Range("c4:c" & x), Range("c" & x).Text) > 1 Then
Range("c" & x).ClearContents

End If
Next x
End Sub

I want to repeat this process for columns C through to BA.

At the moment all I am doing is copying the macro and copying the range for each column, which gives me about 50 sets of code.

Is there a more efficient way to do this?

any ideas?

Many thanks,

Nicko

[Bob Phillips]

Untetsed. I wasn't clear why the countif started at row 4 especially as you step back past it,so I sed all of the column



Sub clearDupsC()
Dim j As Long
Dim x As Long
Dim LastRow As Long

For j = 3 To 53

LastRow = Cells(Rows.Count, j).End(xlUp).Row
For x = LastRow To 1 Step -1

If Application.CountIf(Columns(j), Cells(4, j).Value) > 1 Then

Cells(4, j).ClearContents
End If
Next x
Next j
End Sub

[malik641]

If you want speed, try my code for deleting duplicates. I checked it on 24000 rows in one column (with MANY duplicates) and it ran in under 0.25 seconds:

Option Explicit

Public Sub DeleteDups(ByRef ws As Excel.Worksheet, ByVal iColumn As Long, ByVal iStartRow As Long)
Dim dict As Object
Dim iLastRow As Long
Dim iRow As Long
Dim iNewRowLength As Long

iLastRow = ws.Cells(ws.Rows.Count, iColumn).End(xlUp).Row
If iLastRow <= iStartRow Then Exit Sub

Set dict = CreateObject("Scripting.Dictionary")

For iRow = iStartRow To iLastRow
If Not dict.Exists(ws.Cells(iRow, iColumn).Value) Then
dict.Add ws.Cells(iRow, iColumn).Value, Nothing
iNewRowLength = iNewRowLength + 1
End If
Next

Application.ScreenUpdating = False

ws.Range(ws.Cells(iStartRow, iColumn), ws.Cells(iLastRow, iColumn)).ClearContents
ws.Range(ws.Cells(iStartRow, iColumn), ws.Cells(iStartRow + iNewRowLength - 1, iColumn)).Value = WorksheetFunction.Transpose(dict.Keys)

Application.ScreenUpdating = True
End Sub

Public Sub driverProgram()
Dim iColumn As Long, iStartRow As Long
iStartRow = 4
For iColumn = 3 To 53
Call DeleteDups(ActiveSheet, iColumn, iStartRow)
Next
End Sub

I made the driverProgram() for you to work with your worksheet. Just run that sub to test.

[nicko]

I have tried both versions.

The first works well but takes nearly an hour on my computer.

malik641,
Your version is fast! although it hits an error on column s (19) at...


ws.Range(ws.Cells(iStartRow, iColumn), ws.Cells(iStartRow + iNewRowLength - 1, iColumn)).Value = WorksheetFunction.Transpose(dict.Keys)


any ideas?

Nicko

[malik641]

I'm not sure...

Can you post your workbook? Just the relevant info is all I need. Or if it's sensitive info, try the macro again and let it hit the error, let me know what the error says, and go into the VBE and click View -> Locals and do a Print Screen (Alt+Print Screen) and post the image of the locals window.

[nicko]

Hi there,

Sorry for my delayed response.

I've tried it the macro a few times and it has worked perfectly.

I dont know why it was hitting an error, but its working well now!

Many thanks,

Nick

[malik641]

Glad to hear it! If you feel this thread is resolved, please mark it so by clicking Thread Tools -> Mark Thread Solved -> Perform Action
:thumb