1

Assume that this is my data in Excel Data containing duplicate values in the first three columns. As you can see the values in the first three columns are repeated for a number of rows.

I want to remove the duplicate values in them just like this screenshot duplicate values are removed using a macro

I decided to use a macro that does this for me automatically and I found this VBS code that removes the duplicate values. What the macro actually does is that it removes the repeating values in the selected area where the cursor is in, so each time the macro runs I have to select the area that I would like the values to be removed. But, what I want is to remove the duplicates from the columns A, B, and C whether or not they are selected and no matter how many rows there are. And, I want it to work on open automatically.

I considered using Range() instead of Selection() e.g. I put something like Set r = Columns("A:C").Select but that didn't work. Is there a way to do this in VBS?

Option Explicit

Private originalValues()
Private originalRange As String

Sub removeDupes()
 Dim r As Range 'target range
 Dim arr() 'array to hold values
 Dim i As Long, j As Long, k As Long 'loop control
 Dim upper1D As Long, upper2D As Long, lower2D As Long 'array bounds
 Dim s As String 'temp string to compare values 

  Set r = Selection.Resize(Cells.SpecialCells(xlLastCell).Row)

  If r.Rows.Count = 1 Then Exit Sub 'if the target range is only 1 row then quit
   arr = r.Value 'copy the values in r to the array

 'store the values for an undo
originalValues = r.Value
originalRange = r.Address

upper1D = UBound(arr) 'get the upper bound of the array's 1st dimension
upper2D = UBound(arr, 2) 'get the upper bound of the array's 2nd dimension
lower2D = LBound(arr, 2) 'get the lower bound of the array's 2nd dimension

 'loop through 'rows' in the array
For i = LBound(arr) To upper1D
     'loop through all the 'columns' in the current row
    For j = lower2D To upper2D
        s = arr(i, j) 'record the current array component value in s
         'Check to see if duplicates exists in the target range
        If Application.CountIf(r.Columns(j), s) > 1 _
        And LenB(s) Then
             'Duplicate found: if the end of the array has not ye been reached then
             'loop through the remaining rows for this column, clearing duplicates
            If i < upper1D Then
                For k = i + 1 To upper1D
                    If arr(k, j) = s Then arr(k, j) = ""
                Next k
            End If
        End If
    Next j
Next i
 'copy array back to target range
r.Value = arr
Application.OnUndo "Undo remove duplicates", "restoreOriginalValues"
 End Sub

 Private Sub restoreOriginalValues()
  Range(originalRange).Value = originalValues
 End Sub

Thanks, Laleh

1

1 Answer 1

1

you have to hardcode the range, like :

with Worksheets("MySheet") '<~~ change the worksheet name as per your actual one
    Set r = .Range("A2:C2", .Cells(.Rows.Count, "A").End(xlUp)) '<~~ assuming data are beginning from row 2, otherwise simply change row reference
end with

please consider it's always much safer to explicitly reference the Worksheet name in any Range

this should specially apply to restoreOriginalValues() sub since:

  • Address property of Range object would store the "pure" range cells address without any sheet reference

  • restoreOriginalValues could be possibly called after some "sheet-jumping"

so that you'd better define a module scoped Worksheet variable and then use it

Private originalValues()
Private originalRange As String
Private mySht As Worksheet '< ~~ set module scoped `Worksheet` variable

Sub removeDupes()

'... code

 originalRange = dataRng.Address '<~~ store the "pure" range cells address without any sheet reference

'... code

End Sub


Private Sub restoreOriginalValues()
    mySht.Range(originalRange).Value = originalValues '< ~~ combine module scoped `Worksheet` and `originalRange` variables 
End Sub

here follows an alternative approach looping through cells instead of using arrays. it's just for reference since arrays are surely faster where lots of data are concerned

Option Explicit

    Private originalValues()
    Private originalRange As String
    Private mySht As Worksheet

    Sub removeDupes()
        Dim cell As Range, compCell As Range
        Dim headerRng As Range, dataRng As Range

        Set mySht = Worksheets("MyData")

        With mySht '<~~ change the worksheet name as per your actual one
            Set headerRng = .Range("A2:C2") '<~~ change the header columns reference as per your needs
            Set dataRng = Range(headerRng.Offset(1), .Cells(.Rows.Count, headerRng.Columns(1).Column).End(xlUp)) '<~~ set data range from row below headers to the row with last non empty cell in first header column

            'store the values for an undo
            originalValues = dataRng.Value
            originalRange = dataRng.Address

            For Each cell In dataRng '<~~ loop through every cell
                Set compCell = IIf(IsEmpty(cell.Offset(-1)), cell.End(xlUp), cell.Offset(-1)) '<~~ set the cell whose value is to compare the current cell value to
                If cell.Value = compCell.Value Then cell.ClearContents '<~~ clear current cell only if its value is the same of its "comparing" cell one
            Next cell

        End With

        restoreOriginalValues

    End Sub


    Private Sub restoreOriginalValues()
        mySht.Range(originalRange).Value = originalValues
    End Sub
1
  • your selection solution works perfect! thanks for this. :)
    – Laleh H
    May 19, 2016 at 9:30

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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