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 | | |
+---------------+------+------+------+---------------+---------------+
| tosif | 1 | 2 | 2 | | |
+---------------+------+------+------+---------------+---------------+
| qadeer satter | 3 | 2 | 3 | | |
+---------------+------+------+------+---------------+---------------+
| asif | 4 | 3 | 2 | | |
+---------------+------+------+------+---------------+---------------+
| hamid | 1 | 5 | 2 | | |
+---------------+------+------+------+---------------+---------------+

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 Next
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 aRange.Select 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 Else 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)) Else 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 dubCheckCell1.ClearContents Else End If GoTo nextdubCheckCell1 Loop 'For do while
nextdubCheckCell1: Next dubCheckCell1 'Next for dubCheckRange
nextaCell: Next aCell 'Next for aRange Next 'For drow End Sub

4

3 Answers

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 Next Next Next
End Sub

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

1

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.

1

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) = "" Else 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 .EntireColumn.AutoFit
End With
End Sub

2

Your Answer

Sign up or log in

Sign up using Google Sign up using Facebook Sign up using Email and Password Submit

Post as a guest

Post Your Answer Discard

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