Remove Duplicates Without shifting cells VBA

**MiglA06** · 06-29-2020, 02:07 AM

I'm trying to remove duplicates using VBA macro. Columns a,b,c and d on my sheet all have duplicate text that needs to be removed without shifting cells. After searching I was able to find the VBA macro below but I need to select a range every time. I need to streamline it to only be done once. Can someone please help? Thanks

Remove.png

Sub RemoveDuplicates()
'UpdatebyExtendoffice20160918
 
    Dim xRow As Long
    Dim xCol As Long
    Dim xrg As Range
    Dim xl As Long
    On Error Resume Next
    Set xrg = Application.InputBox("Select a range:", "Kutools for Excel", _
                                    ActiveWindow.RangeSelection.AddressLocal, , , , , 8)
 
    xRow = xrg.Rows.Count + xrg.Row - 1
    xCol = xrg.Column
    'MsgBox xRow & ":" & xCol
    Application.ScreenUpdating = False
    For xl = xRow To 2 Step -1
        If Cells(xl, xCol) = Cells(xl - 1, xCol) Then
            Cells(xl, xCol) = ""
        End If
    Next xl
    Application.ScreenUpdating = True
     
End Sub

**jindon** · 06-29-2020, 03:34 AM

1)
Please take a moment to add the tags. Posting code between tags makes your code much easier to read and copy for testing, and it also maintains VBA formatting.

Please see Forum Rule #2 about code tags and adjust accordingly. Click on Edit to open your post, then highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here

2) untested

Sub test()
    Dim a, i As Long, ii As Long, txt As String, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            For ii = 1 To 4
                txt = txt & Chr(2) & a(i, ii)
            Next
            If Not dic.exists(txt) Then
                dic(txt) = Empty
            Else
                .Rows(i).ClearContents
            End If
            txt = ""
        Next
    End With
End Sub

**ORoos** · 06-29-2020, 03:49 AM

Hi there,

Your macro is deleting the duplicate in the first column selected, the rest of the row remains as is. if this is what you need and you only want to replace the input box try the below.
Provided your data starts in A1 and has no blank rows in column A, you can do it with changing one line:

Sub RemoveDuplicates()
'UpdatebyExtendoffice20160918

Dim xRow As Long
Dim xCol As Long
Dim xrg As Range
Dim xl As Long
On Error Resume Next
Set xrg = ActiveSheet.Range("A1").CurrentRegion
'Set xrg = Application.InputBox("Select a range:", "Kutools for Excel", _
'ActiveWindow.RangeSelection.AddressLocal, , , , , 8)

xRow = xrg.Rows.Count + xrg.Row - 1
xCol = xrg.Column
'MsgBox xRow & ":" & xCol
Application.ScreenUpdating = False
For xl = xRow To 2 Step -1
If Cells(xl, xCol) = Cells(xl - 1, xCol) Then
Cells(xl, xCol) = ""
End If
Next xl
Application.ScreenUpdating = True

End Sub

**MiglA06** · 06-29-2020, 03:50 AM

Thanks. I've made the changes and attached a test file.

**MiglA06** · 06-29-2020, 03:53 AM

No i want to delete duplicates on multiple columns not just one. I want to delete duplicates on columns A thru D.

**jindon** · 06-29-2020, 04:05 AM

Do you mean?

Sub test()
    Dim a, i As Long, ii As Long, txt As String, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    With Cells(1).CurrentRegion
        a = .Value
        For i = 2 To UBound(a, 1)
            For ii = 1 To 4
                txt = txt & Chr(2) & a(i, ii)
            Next
            If Not dic.exists(txt) Then
                dic(txt) = Empty
            Else
                .Rows(i).Resize(, 5).ClearContents
            End If
            txt = ""
        Next
    End With
End Sub

**MiglA06** · 06-29-2020, 04:13 AM

Yes that worked good but it also erased text from column E and then gave me a debug error. I only need columns A thru D

Remove.png

**jindon** · 06-29-2020, 04:16 AM

OOps, 5 shohld be 4

.Rows(i).Resize(, 4).ClearContents

**MiglA06** · 06-29-2020, 04:20 AM

That worked perfect but it still gave me a debug error on the this.

      txt = txt & Chr(2) & a(i, ii)

**jindon** · 06-29-2020, 04:24 AM

Do you have Error value?
try change that line to

      txt = txt & Chr(2) & CStr(a(i, ii))

**MiglA06** · 06-29-2020, 04:29 AM

Yes that did. That works perfectly. Thanks you're awesome.

Remove Duplicates Without shifting cells VBA

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Re: Remove Duplicates Without shifting cells VBA

Thread Information

Users Browsing this Thread

Similar Threads

VBA code to remove duplicates without shifting cells

Excel 2003 vba Add and remove from listbox shifting cells up when removed

[SOLVED] Combine cells and remove duplicates

Remove cells if duplicates found

[SOLVED] Find Duplicates and add columns while shifting the cells up

[SOLVED] concatinate cells and remove duplicates

Formatting cells to remove duplicates

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions