I am working on a large document that has a couple hundred columns of data. Many of these rows have duplicate values in the columns that I need to remove.

Here is a sample sheet:

enter image description here

What I need is to be able to go through each row, find the duplicates in columns B:E and delete all but one of the cells, preferably shifting the rest of the cells left to avoid blank cells. I would need to keep all rows and the rest of their data intact.

So, given the above example, the result would look like this:

enter image description here

A couple notes:

  • The cells in question all appear at the end of each row
  • Reasoning: All these values were stored as a list in a single column and split out using Text to Columns. I now need to clean it up and remove the duplicates.
  • There are thousands of rows and a couple hundred of extra columns that may have duplicates.

Is this possible, even with VBA? Any suggestions are greatly appreciated. Thank you!


Here are the speed test results for the posted answers (10K rows and 1K columns):

VBA 1 - Time:  19.488 sec - RemoveRowDupes (this answer)

VBA 2 - Time: 109.434 sec - dostuff (after turning off ScreenUpdating)

Formula test: N/A (gave up after 5 minutes filling out 10Kx1K range with array, at 9%)

Option Explicit
Public Sub RemoveRowDupes()
    Dim ur As Range, cc As Long, r As Range, a As Variant
    Dim s As String, i As Long, l As Long, t As Long, tt As Double, tr As String
    tt = Timer
    Set ur = Sheet1.UsedRange
    cc = ur.Columns.Count - 1
    With ur.Offset(, 1).Resize(, cc)
        Application.ScreenUpdating = False
        For Each r In .Rows
            s = Join(Application.Transpose(Application.Transpose(r)), "|")
            a = Split(s, "|"):
            l = Len(s)
            For i = 0 To cc - 1
                If Len(a(i)) > 0 Then
                    s = Replace(s, a(i), "^^")
                    s = Replace(s, "^^", a(i), , 1)
                    s = Replace(s, "^^", vbNullString)
                    If l > Len(s) Then
                        a = Split(s, "|")
                        l = Len(s)
                    End If
                End If
            s = Replace(s, "||", "|")
            If Right(s, 1) = "|" Then s = Left(s, Len(s) - 1)
            t = Len(s) - Len(Replace(s, "|", ""))
            r.ClearContents:    r.Resize(, t + 1) = Split(s, "|")
        Application.ScreenUpdating = True
    End With
    tr = "Rows: " & Format(ur.Rows.Count,"#,###") & "; Cols: " & Format(cc,"#,###") & "; "
    Debug.Print tr & "Time: " & Format(Timer - tt, "0.000") & " sec - RemoveRowDupes()"
End Sub

Test data:


Result - RemoveRowDupes()


Result - dostuff()


Note: this answer can be improved (if needed) by using arrays instead of interacting with the range

  • Looks good, @paul bica, but when I run it, nothing happens. I am unfamiliar with VBA, but I added a module to the sheet with my data and pasted your code. How would I actually run this on my range? – Zephyr Apr 12 '18 at 1:00
  • Right now the sheet is just the default Sheet 1, which seems to match what's in your code. – Zephyr Apr 12 '18 at 1:05
  • It doesn't match (it has to be exact): Sheet 1 has a space before 1. Either remove the space, or go in the VBA editor and look at the top-left pane: you will see 2 names for the same sheet (I know - it can be confusing), but tell me both (exact) names for your sheet with data – paul bica Apr 12 '18 at 1:07
  • Well, I'm confused then. In the VBA window, the sheet I want is displayed as "Sheet2 (Sheet1)" and the code references "Sheet1.UsedRange". I have tried changing it to Sheet2.UsedRange, but again no effect. – Zephyr Apr 12 '18 at 1:09
  • Ah, found it! Turns out, I added a general module, but it wasn't actually added to the right sheet. Doing that and changing to Sheet2 worked perfectly. Thank you! – Zephyr Apr 12 '18 at 1:14

If you wanted to use VB to process the data in place, you could use the following:

Sub dostuff()
Dim myarray As Variant
ReDim myarray(10000)

i = 0 'row iterator

Do While (Range("A1").Offset(i, 0).Value <> "")
 j = 0 'single item iterator
 k = 0 'column iterator
 m = 0 'stored array iterator
 m_max = 0 'number of unique values on the row

 'iterate single values
 Do While (Range("B1").Offset(i, j).Value <> "")
  temp = Range("B1").Offset(i, j).Value

  'compare to saved
  flag = 0
  m = 0
  Do While (m <= m_max)
   If temp = myarray(m) Then
     flag = 1
   End If
   m = m + 1

  'add if unique
  If flag = 0 Then
   m_max = m_max + 1
   myarray(m_max) = temp
  End If

  j = j + 1

 'clear existing
 Range("B1").Offset(i, 0).Select
 Range(Selection, Selection.End(xlToRight)).Clear

 'write saved
 m = 1
 Do While m <= m_max
  Range("B1").Offset(i, m - 1).Value = myarray(m)
  m = m + 1

  i = i + 1
End Sub

You can do this with a formula, but the correct values will be in a different location, at least temporarily. To keep your data in the same location, you can copy the new data and Paste Special > Values over the old data.

This array formula, filled right and down from B7, gives the results shown below:


Note that this is an array formula and must be entered with CTRLShiftEnter.

enter image description here

A tutorial on how this formula works is given at Exceljet.

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.