Clear duplicates in a column if adjacent cell is not empty-CodePudding

Having some trouble adding in the 'if adjacent cell is not empty' condition.

The macro should clear (not delete) all duplicates in column, if the adjacent cell to the left is also not empty.

Sub FBMDups()

Dim LR As Long, i As Long
LR = Range("H" & Rows.Count).End(xlUp).row
For i = LR To 1 Step -1
    If WorksheetFunction.CountIf(Columns("H"), Range("H" & i).Value) > 1 And i.Offset(, 1) <> 0 Then Range("H" & i).Clear
    
Next i
End Sub

Edit:

To clarify -

G	H
1	A
2	B
3	C
4	C
5	D
6	C
7	E
	C
	C
8	F

Would turn into

G	H
1	A
2	B
3	C
4
5	D
6
7	E
	C
	C
8	F

Duplicate C's after the original where deleted, also long as the adjacent cell was empty.

CodePudding user response：

Clear Duplicates With Condition

Sub FBMDups()

    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim fCell As Range: Set fCell = ws.Range("G1")
    Dim lCell As Range: Set lCell = ws.Cells(ws.Rows.Count, "H").End(xlUp)
    Dim rg As Range: Set rg = ws.Range(fCell, lCell)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive i.e. 'a = A'
    
    Dim rrg As Range
    Dim cKey As Variant
    
    For Each rrg In rg.Rows
        If Len(CStr(rrg.Cells(1).Value)) > 0 Then ' is not blank
            cKey = rrg.Cells(2).Value
            If dict.Exists(cKey) Then ' is a duplicate
                rrg.Cells(2).ClearContents ' clear
            Else ' is not a duplicate
                dict(cKey) = Empty ' add to the keys of the dictionary
            End If
        'Else ' is blank; do nothing
        End If
    Next rrg
    
End Sub

CodePudding user response：

Another option:

Sub FBMDups()

    Dim i As Long, ws As Worksheet
    Set ws = ActiveSheet 'or some other sheet...
    
    For i = ws.Range("H" & Rows.Count).End(xlUp).row To 1 Step -1
        If Len(ws.Range("G" & i).Value) > 0 Then
            If WorksheetFunction.CountIfs(ws.Columns("H"), ws.Range("H" & i).Value, _
                                      ws.Columns("G"), "<>") > 1 Then ws.Range("H" & i).Clear
        End If
    Next i
End Sub