Remove Duplicates From A Row - excel

Question

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
Next
End Sub
So what I need is some code to do what I need inserted after below code.
Set nextRang = Range(sCellStr, eCellStr)
If there is a simple solution to this like ".RemoveDuplicates" then please let me know. As of now I am thinking of doing this through looping but it seems complex as I think I will need at least 3 "for each" loops and 3 "if conditions", 2 more row ranges and probably something else when I start doing it like that.
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..
So I also worked on the code to remove duplicates for rows. Below is my code, its working for me. It is complex and people over stackoverflow provided better code.
Sub removeRowDublicates()
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

Answer 1

Try the next code, please:
Sub testRemoveRowDuplicates()
Dim sh As Worksheet, rng As Range, lastRow As Long, i As Long
Set sh = ActiveSheet 'use here your sheet
lastRow = sh.Range("A" & Rows.Count).End(xlUp).row
For i = 2 To lastRow
Set rng = sh.Range("C" & i & ":D" & i)
rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
Set rng = sh.Range("D" & i)
rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
Set rng = sh.Range("F" & i)
rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
Next i
End Sub
The above code assumes that a name cannot be duplicate in the email columns. It removes duplicates on each category (names and emails).
If you really need to check each value of the row, please, use the next variant:
Sub testRemoveRowDuplicatesBis()
Dim sh As Worksheet, rng As Range, lastRow As Long
Dim i As Long, j As Long
Set sh = ActiveSheet
lastRow = sh.Range("A" & Rows.Count).End(xlUp).row
For i = 2 To lastRow
For j = 3 To 6 'last column
Set rng = sh.Range(sh.Cells(i, j), sh.Cells(i, 6))
rng.Replace rng.Cells(1, 1).Offset(0, -1).Value, "", xlWhole
Next j
Next i
End Sub

Answer 2

You can use some VBA nested loops to do this - loop the rows, and then have two column loops to check the values of the cells:
Sub sRemoveRowDubs()
On Error GoTo E_Handle
Dim ws As Worksheet
Dim lngLastRow As Long
Dim lngLastCol As Long
Dim lngRow1 As Long
Dim lngCol1 As Long
Dim lngCol2 As Long
Set ws = Worksheets("Sheet4")
lngLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
lngLastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
For lngRow1 = 1 To lngLastRow
For lngCol1 = 1 To lngLastCol
For lngCol2 = lngCol1 + 1 To lngLastCol
If ws.Cells(lngRow1, lngCol1) = ws.Cells(lngRow1, lngCol2) Then
ws.Cells(lngRow1, lngCol2) = ""
End If
Next lngCol2
Next lngCol1
Next lngRow1
sExit:
On Error Resume Next
Set ws = Nothing
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "sRemoveRowDubs", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards,

Answer 3

If you can use formula and create a new table.
Array (CSE) Formula for Num1 column, enter the formula in formula bar, press control+Shift+Enter and then select the cell copy to Num2 and Num3. Then select all three cells and copy down.
=IFERROR(INDEX($B2:$D2,1,MATCH(0,COUNTIF($H2:H2,$B2:$D2),0)),"")
Array (CSE) Formula for email1 column, enter the formula in formula bar, press control+Shift+Enter and then select the cell copy to email2. Then select those two cells and copy down.
=IFERROR(INDEX($E2:$F2,1,MATCH(0,COUNTIF($K2:K2,$E2:$F2),0)),"")

Answer 4

Or maybe something like this?
Sub test()
Set rngName = Range("A2", Range("A" & Rows.Count).End(xlUp))
For Each cell In rngName
For i = 1 To 4
Set Rng = Range(cell.Offset(0, i + 1), Cells(cell.Row, 6))
Set c = Rng.Find(cell.Offset(0, i).Value, lookat:=xlWhole)
If Not c Is Nothing Then c.ClearContents
Next i
Next cell
End Sub
What I am thinking is selecting 1 cell from row then check it against
all other cells in the same row
The code assumes that there will be no blank in between row with value under column NAME (column A), and all the name value is unique. This is for the first loop.
The second loop is the how many cell in the same row to check, in this case there are 4 cells to check (num1, num2, num3 and email1) then so does the checking are 4 times ---> in the same row : check num1 against num2, num3, email1 and email2 ... check num2 against num3, email1 and email2 .... check num3 against email1 and email2... then finally check email1 against email2. On each check, if the same value is found, then the code put blank to the found cell.

Answer 5

Clear Duplicate Entries By Row
Copy the complete code into a standard module (e.g. Module1).
Only run the first Sub, the other two are being called.
Adjust the constants in the first Sub, including the workbook.
The Code
Option Explicit
Sub clearDups()
Const wsName As String = "Sheet1"
Const FirstRowAddress As String = "A2:F2"
Const LastRowColumn As Long = 1
Const Replacement As Variant = Empty
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Data First Row Range.
Dim rng As Range: Set rng = wb.Worksheets(wsName).Range(FirstRowAddress)
' Define Data Range and write its values to Data Array.
Dim Data As Variant: getRangeValuesFR Data, rng, LastRowColumn
If IsEmpty(Data) Then Exit Sub
' In data array, clear duplicate values by row
' (from the top and from the left).
replaceDupsByRow Data, Replacement
' Write modified values from Data Array to Data Range.
rng.Resize(UBound(Data)).Value = Data
End Sub
Sub getRangeValuesFR(ByRef Data As Variant, _
ByRef FirstRowRange As Range, _
Optional ByVal LastRowColumn As Long = 1)
Dim rng As Range
If LastRowColumn = 0 Then GoSub LastRow0 Else GoSub LastRowN
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRowRange.Row Then Exit Sub
Set rng = FirstRowRange.Resize(rng.Row - FirstRowRange.Row + 1)
If rng.Row > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
End If
Exit Sub
LastRow0:
With FirstRowRange
Set rng = .Worksheet.Columns(.Column).Resize(, .Columns.Count) _
.Find("*", , xlValues, , xlByRows, xlPrevious)
End With
Return
LastRowN:
With FirstRowRange
Debug.Print .Columns(LastRowColumn).Address
Set rng = .Worksheet.Columns(.Columns(LastRowColumn).Column) _
.Find("*", , xlValues, , , xlPrevious)
End With
Return
End Sub
Sub replaceDupsByRow(ByRef Data As Variant, _
Optional ByVal Replacement As Variant = Empty)
Dim Curr As Variant, i As Long, j As Long, l As Long
For i = 1 To UBound(Data)
For j = 1 To UBound(Data, 2) - 1
Curr = Data(i, j + 1)
If Curr <> Replacement Then GoSub loopSubRows
Next j
Next i
Exit Sub
loopSubRows:
For l = 1 To j
If Curr = Data(i, l) Then
Data(i, j + 1) = Replacement: Exit For
End If
Next l
Return
End Sub