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!!
duplicates.bmp
acramer_dominiumAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rgonzo1971Commented:
Hi,

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
Next

End Sub

Open in new window

Regards
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
FamousMortimerCommented:
If you want to clear the entire row, change

Range("A" & IdxRow) = ""

to

Rows(IdxRow).ClearContents
0
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
    Next
0
broro183Commented:
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
            Loop
        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


hth
Rob
0
acramer_dominiumAuthor Commented:
That worked perfectly! Thank you!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.