I am facing problem with removing duplicate from a single row. I want to loop through all rows in a range and remove duplicate from a single row without effecting rest of data in sheet. Here is sample data:

| name          | num1 | num2 | mun3 | emial1        | email2        |
| ali zubair    | 1    | 2    | 1    | az@az.com     | az@az.com     |
| tosif         | 1    | 2    | 2    | t@zb.com      | t@gb.com      |
| qadeer satter | 3    | 2    | 3    | qs@mtm.com    | star@mtn.com  |
| asif          | 4    | 3    | 2    |               |               |
| hamid         | 1    | 5    | 2    | hamid@beta.ds | hamid@beta.ds |

Below code removes duplicate rows based on column 2, it is not applicable in my case.

ActiveSheet.Range("A1:f100").RemoveDuplicates Columns:=Array(2), Header:=xlYes

I have no idea how I can remove duplicate from a selected row range. So far I have the code that will loop through all rows in my data.

    Sub removeRowDubs()
      Dim nextRang As Range
      Dim sCellStr As String, eCellStr As String
      Dim dRow As Long
      dRow = Cells(Rows.Count, 1).End(xlUp).Row
        For dRow = 2 To dRow
               sCellStr = Range("A" & dRow).Offset(0, 1).Address
               eCellStr = Cells(dRow, Columns.Count).End(xlToLeft).Address
        Set nextRang = Range(sCellStr, eCellStr)
             Debug.Print nextRang.Address
End Sub

So what I need is some code to do what I need inserted after below code.

Set nextRang = Range(sCellStr, eCellStr) 

I hope I made my question clear and I will really appreciate your help. I am new at Excel VBA coding, your patience is needed..

I also worked on my code, code is provided below. It is working for me however people who answered my question provided better code.

Sub removeRowDuplicates()
      Dim nextRang As Range                             ' Variables for
      Dim sCellStr As String, eCellStr As String        ' Going through all rows
      Dim dRow As Long                                  ' And selecting row range
        dRow = Cells(Rows.Count, 1).End(xlUp).Row    ' This code selects the                                         
        For dRow = 2 To dRow                         ' next row in the data                                                           
               sCellStr = Range("A" & dRow).Offset(0, 1).Address                            
               eCellStr = Cells(dRow, Columns.Count).End(xlToLeft).Address        
        Set nextRang = Range(sCellStr, eCellStr)                                                       
        Dim aRange As Range, aCell As Range                ' Variables for                               
        Dim dubCheckCell As Range, dubCheckRange As Range  ' Loops to remove
        Dim dubCheckCell1 As Range                         ' Dublicates from                             
        Dim columnNum As Integer                           ' Current row                                
        Set aRange = nextRang
        columnNum = Range("b2:f2").Columns.Count + 1
              For Each aCell In aRange    'Loop for selecting 1 cell, if not blank from range to check its value against all other cell values

                                 If aCell.Value <> "" Then
                                    Set dubCheckCell = aCell
                                             GoTo nextaCell   'If current cell is blank then go to next cell in range
                                 End If
                      If dubCheckCell.Offset(0, 2).Value <> "" Then                   'Selects range by offsetting 1 cell to right from current cell being checked for dublicate value
                   Set dubCheckRange = Range(dubCheckCell.Offset(, 1), dubCheckCell.Offset(, 1).End(xlToRight))
                   Set dubCheckRange = Range(dubCheckCell.Offset(0, 1).Address)
                   End If
    For Each dubCheckCell1 In dubCheckRange   'Loop that goes through all cells in range selected by above if-statement
      Do While dubCheckCell1.Column <= columnNum
         If dubCheckCell = dubCheckCell1 Then
                          End If
             GoTo nextdubCheckCell1
             Loop         'For do while
        Next dubCheckCell1            'Next for dubCheckRange
        Next aCell                    'Next for aRange
              Next    'For drow
    End Sub
  • What is the expected output/results? – Reddy Lutonadio Jun 27 at 14:01
  • I have dublicates in many rows in my data, say row1 has 3 columns and values are 1,1,2. I want to keep 1,2 and remove 1 as it is repeated/dublicate. – Ali Zubair Jun 27 at 14:06
  • I was hoping for a simple solution like .RemoveDublicates, currently I am thinking of doing this through looping, e.g. set row as range, then for each cell in range I check it against all other remaining cells in that row but it will complicate things. – Ali Zubair Jun 27 at 14:07
  • If there some simple solution to this then please let me know otherwise I can do this by looing but that will complex code and if I dont have any option I will go through it and will share my result here. – Ali Zubair Jun 27 at 14:10

I modified the macro to use my own variables. What the macro starts by getting the number of rows and columns. Then loop through rows, columns and cells while comparing values. If a duplicate value is found, it is replaced with an empty value.

Sub removeRowDubs()
    Dim dRow As Long
    Dim dCol As Double
    Dim i, j, k As Integer
    Dim rng As Range
    i = 1
    dCol = 0
    Set rng = Range(i & ":" & i)
    'Get the rows
    dRow = Cells(Rows.Count, 1).End(xlUp).Row
    'Get the columns
    dCol = WorksheetFunction.CountIfs(rng, "<>" & "")
    'Contains the value to search
    Dim cvalue As String
    'Loop through the rows
    For i = 2 To dRow
        'Loop through the columns
        For j = 2 To dRow
            cvalue = Cells(i, j).Value
            'Loop through the cells
            For k = (j + 1) To dCol
                If Cells(i, k).Value = cvalue Then
                    Cells(i, k).Value = ""
                End If
End Sub

Click to enlarge the gif image to see the macro in action.

enter image description here

| improve this answer | |
  • Hello Reddy, your code is working. Thanks You – Ali Zubair Jul 1 at 14:03

You can use a loop like this:

Sub remdupes()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Dim MyArr As Variant
Dim x As Long, j As Long, n As Long
MyArr = Sheet8.Range("A1").CurrentRegion
 For x = LBound(MyArr, 1) To UBound(MyArr, 1)
        For j = LBound(MyArr, 2) To UBound(MyArr, 2) - 1
           For n = j + 1 To UBound(MyArr, 2)
                If UCase(MyArr(x, j)) = UCase(MyArr(x, n)) Then MyArr(x, n) = vbNullString
            Next n
        Next j
    Next x

Sheet8.Range("A1").CurrentRegion = MyArr
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

If you have data contiguous to the region you are removing the duplicates from just change the .currentregion reference to be the range you want to edit.

| improve this answer | |
  • Hello Justin, Your code is also doing what is needed. Apparently I can only select 1 answer. Thank you for for the help, I will study your code as well. – Ali Zubair Jul 1 at 14:04

I like using a Dictionary object to remove duplicates. It's quick, easy, and easy to understand.

I also prefer to work with VBA arrays rather than repeated read/write to/from the worksheet. This will usually result in speeding up the routine 5-10 fold. (although with small amounts of data, the actual differences may be negligible. Still, it's a habit).

Both are demonstrated below.

Option Explicit
Sub remDupRows()
    Dim WS As Worksheet, R As Range
    Dim LR As Long, LC As Long
    Dim vData As Variant
    Dim I As Long, J As Long
    Dim D As Object
'Set worksheet and data range
Set WS = ThisWorkbook.Worksheets("sheet10")

With WS
    LR = .Cells(.Rows.Count, 1).End(xlUp).Row
    LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
    Set R = .Range(.Cells(1, 1), .Cells(LR, LC))
End With

'read data into variant array for faster processing
vData = R

'use dictionary for removing duplicates from each row
For I = 2 To UBound(vData, 1)
    Set D = CreateObject("scripting.dictionary")
        D.CompareMode = vbTextCompare 'case insensitive
    For J = 1 To UBound(vData, 2)
        If D.Exists(vData(I, J)) Then
            vData(I, J) = ""
            D.Add vData(I, J), vData(I, J)
        End If
    Next J
Next I

'write the results back to the worksheet
'could overwrite the original data, but won't do that here
Set R = WS.Cells(LR + 2, LC + 2)
Set R = R.Resize(UBound(vData, 1), UBound(vData, 2))

With R
    .Value = vData
    .Style = "Output" 'not internationally aware
End With

End Sub

enter image description here

| improve this answer | |
  • Hello Ron, I tried your code, I am getting "variable not declared" error at line "D.CompareMode = TextCompare", I tried declaring variabler then I got type mismatch error. – Ali Zubair Jul 1 at 14:09
  • @AliZubair Oops. That should be vbTextCompare. I'll change it in the code. Do NOT declare it. – Ron Rosenfeld Jul 1 at 15:42

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.