VBA Script identify duplicates and clear contents specific cells

[cizzett]

Hello group,
I was looking for some help making a script that will identify the last row used, go through column E to find duplicates, once it finds duplicated it will clear contents of cells D:E and G:L on the row leaving only the first instance of the number intact. I do not want to delete the cells as it will change the alignment of other cells and thus ruin the spreadsheet.

There may be only 2 lines or 4 or 5 lines duplicate but the duplicated will be grouped together.

Thanks

 

[richh]

I THINK this should work. Might need a little tinkering to get it right. Definitely test it on a copy of your data, not the original dataset to avoid... ya know... wrecking your work.

Dim lRow as Long
Dim ws   as Worksheet

Set ws = Application.Thisworkbook.Worksheets("YourSheetName")

lRow = ws.cells(Rows.Count,1).End(xlUp).Row

For lRow to 2 Step -1
    If ws.Cells(lRow, 5) = ws.cells(lRow -1, 5) Then
        'ws.Rows(""" & lRow & ":" & lRow & """).Select 'Code to delete full row
        'Selection.Delete Shift:=xlUp 
        ws.Range("D" & lRow & ":E" & lRow)  = ""
        ws.Range("G" & lRow & ":L" & lRow) = ""
    End if
Next lRow

 

[JoeMo]

Here's another way to consider:

Sub FindDupsAndClear()
Dim Lrw As Long, R As Range, CalcState, d As Object, c As Range
Set R = Range("E1:E" & Cells(Rows.Count, "E").End(xlUp).Row)
CalcState = Application.Calculation
With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
End With
Set d = CreateObject("Scripting.dictionary")
For Each c In R
    If d.exists(c.Value) Then
        With c
            .Value = ""
            .Offset(0, -1).Value = ""
            .Offset(0, 2).Resize(1, 6).Value = ""
        End With
    Else
        d.Add c.Value, d.Count + 1
    End If
Next c
With Application
    .Calculation = CalcState
    .ScreenUpdating = True
End With
End Sub

 

[Peter_SSs]

Another way to consider that does not require checking every row individually.

Sub Clear_Dupes()
  Application.ScreenUpdating = False
  Cells(2, Columns.Count).Formula = "=MATCH(E2,E:E,0)<>ROW(E2)"
  With Range("E1", Range("E" & Rows.Count).End(xlUp))
    .AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Cells(1, Columns.Count).Resize(2), Unique:=False
    If .SpecialCells(xlVisible).Count > 1 Then Intersect(.EntireRow, Range("D:E, G:L"), Rows("2:" & Rows.Count)).ClearContents
  End With
  ActiveSheet.ShowAllData
  Cells(2, Columns.Count).ClearContents
  Application.ScreenUpdating = True
End Sub