• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1391
  • Last Modified:

Clear Duplicate Cells Using Excel VBA

Experts. I've been searching for a piece of vba code that will work to clear duplicates in a column in excel using vba. I found something that works if the values I want to search for are numerical. I can't seem to find anything that works for text fields.

Attached is a screen shot of the sheet. I will have multiple partners listed. They can be listed x number of time. I would like to show the first one in the group and clear the cells where the name is repeated. Then show the next partner and clear the cells where that name is repeated.

Any ideas? Thank you!!
1 Solution

pls try

Sub Macro

For IdxRow = Range("A" & Rows.Count).End(xlUp).Row to 2 Step -1
    If Range("A" & IdxRow - 1) = Range("A" & IdxRow) Then
        Range("A" & IdxRow) = ""
    End If

End Sub

Open in new window

If you want to clear the entire row, change

Range("A" & IdxRow) = ""


acramer_dominiumAuthor Commented:
Rgonzo1971: that worked perfectly.

Do you know of a way to search for text in the first column. Wherever there is text, insert a row above? I've tried this and isn't working.

    nr = xlSheet.Cells(Rows.Count, 1).End(xlUp).Row
    For r = nr To 2 Step -1
    If xlSheet.Cells(r, 1).Text <> "" Then
    xlSheet.Rows(r - 1).Insert Shift:=xlDown
    End If
hi everyone,

Here is a slight variation on the previous suggestions which will also insert the rows as requested in the last post.

Option Explicit
Public glb_origCalculationMode As Long
Public glb_origStatusBar As String

Sub RemoveDupsAndInsertRows()
Dim ws As Worksheet
Dim PartnerArr As Variant
Dim IdxRow As Long
Dim CurPartner As String    'current partner

    Call ToggleRefreshXlApp(False)

    Set ws = ActiveSheet

    'get list of Partners from sheet
    With ws
        PartnerArr = .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With

    'delete duplicated rows
    'Note this relies on the data being sorted in the spreadsheet before the macro is run.
    For IdxRow = LBound(PartnerArr, 1) To UBound(PartnerArr)
        CurPartner = PartnerArr(IdxRow, 1)
        IdxRow = IdxRow + 1

        If IdxRow <= UBound(PartnerArr) Then
            Do While CurPartner = PartnerArr(IdxRow, 1)
                PartnerArr(IdxRow, 1) = vbNullString
                IdxRow = IdxRow + 1
                If (IdxRow + 1) > UBound(PartnerArr) Then
                    Exit Do
                End If
        End If
        'correct the index number which was modified in the Do Loop
        IdxRow = IdxRow - 1
    Next IdxRow

    'write list of Partners back to sheet without duplicates
    With ws
        .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row).Value2 = PartnerArr
    End With

    'insert a blank row above each row with a partner's name
    For IdxRow = UBound(PartnerArr, 1) To LBound(PartnerArr) Step -1
        If PartnerArr(IdxRow, 1) <> vbNullString Then
            With ws
                .Rows(IdxRow + 1).Insert
            End With
        End If
    Next IdxRow

    Call ToggleRefreshXlApp(True)
    MsgBox "Done"
    Set ws = Nothing
End Sub

Sub RefreshXlApp()
'for use when testing
    With Application
        .EnableEvents = True
        On Error Resume Next
        .Calculation = xlCalculationAutomatic
        On Error GoTo 0
        .StatusBar = False
        .ScreenUpdating = True
        .DisplayFormulaBar = True
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
    End With
End Sub

Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Open in new window

acramer_dominiumAuthor Commented:
That worked perfectly! Thank you!
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

7 new features that'll make your work life better

It’s our mission to create a product that solves the huge challenges you face at work every day. In case you missed it, here are 7 delightful things we've added recently to monday to make it even more awesome.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now