Clear Contents on Column

**martinez_pedro** · 01-12-2012, 10:31 PM

Hi I am looking for some help on this in macro I have over 185000 rows and I ran this code it took over hour to run.
Do you a faster code that can accomplish the same as this one in less time?
Any help is greatly appreciated

Sub ClearDupOnD()
Dim StartRow As Long
Dim EndRow As Long
Dim R As Long
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With
StartRow = 1
EndRow = Cells(StartRow, "B").End(xlDown).Row
For R = EndRow To StartRow Step -1
If Application.CountIf(Range(Cells(1, "D"), _
Cells(R, "D")), Cells(R, "D").Value) > 1 Then
Range("D" & R).ClearContents
End If
Next R
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With
End Sub

**john55** · 01-12-2012, 11:28 PM

hi,
see if it helps you

Sub Button1_Click()
  Application.ScreenUpdating = 0
  Application.Calculation = xlCalculationManual
  Dim cell As Range
  For Each cell In Application.Intersect(ActiveSheet.Range("d:d"), _
         ActiveSheet.UsedRange)
    If Trim(cell.Value) > 1 Then
        ActiveSheet.Range(cell, cell.Offset(0, 4)).ClearContents
    End If
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = 1
  End Sub

if you want to know how long it takes to be completed...

Sub Button1_Click()
Dim start_time, end_time
Dim cell As Range
 Application.ScreenUpdating = 0
Application.Calculation = xlCalculationManual

start_time = Now()
  
  For Each cell In Application.Intersect(ActiveSheet.Range("d:d"), _
         ActiveSheet.UsedRange)
    If Trim(cell.Value) > 1 Then
        ActiveSheet.Range(cell, cell.Offset(0, 4)).ClearContents
    End If
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = 1

end_time = Now()
MsgBox "completed in" & " " & (DateDiff("s", start_time, end_time)) & " " & "seconds"

End Sub

**martinez_pedro** · 01-13-2012, 09:08 PM

beforehand thank for your help I try using the code that you posted and it run really fast but it is giving me different result than the one posted so I attach a sample spreadsheet so you can see why is erasing everything on d and the other 3 columns to the right

**john55** · 01-14-2012, 02:56 AM

hi martinez,
try this one

Sub Button2_Click()

Application.ScreenUpdating = 0
  Application.Calculation = xlCalculationManual
  Dim cell As Range
  For Each cell In Application.Intersect(ActiveSheet.Range("d:d"), _
         ActiveSheet.UsedRange)
    If Trim(cell.Value) > 1 Then
        ActiveSheet.Range(cell, cell.Offset(0, 0)).ClearContents
    End If
  Next
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = 1
End Sub

**Marcol** · 01-14-2012, 06:40 AM

See if this works for you, it should be a tad faster than looping

Sub ClearDupOnD()
    Dim StartRow As Long, LastRow As Long, LastCol As Long
    
    LastRow = Cells(Rows.Count, "B").End(xlUp).Row
    LastCol = Cells(1, Columns.Count).End(xlToLeft).Column
    Cells(2, LastCol + 1).Resize(LastRow - 1, 1).Formula = "=IF(COUNTIF($D$2:$D2,$D2)=1,D2,"""")"
    Range(Cells(2, LastCol + 1), Cells(LastRow, LastCol + 1)).Copy
    Range("D2").PasteSpecial xlPasteValues
    Range(Cells(2, LastCol + 1), Cells(LastRow, LastCol + 1)).ClearContents
    
End Sub