Add a condition to macro-CodePudding

The below code looks for duplicates in Column A, and if a duplicate exists, it sets the adjacent cell in column H to 0.

I've been trying to amend it to look for duplicates in column A as well as E, then if both are duplicates it will set the adjacent cell in column H to 0.

Would appreciate any help.

Dim Cell As Range
   Dim DSO As Object
   Dim Rng As Range
       
     Set Rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
     
     Set DSO = CreateObject("Scripting.Dictionary")
     DSO.CompareMode = 1
     
       For Each Cell In Rng
         If DSO.Exists(Cell.Text) Then
            Cell.Offset(0, 7) = 0
         Else
            DSO.Add Cell.Text, Cell
         End If
      Next Cell
    
    Set DSO = Nothing
    
End Sub

CodePudding user response：

You could do something like this:

Sub Dups()
    Dim ws As Worksheet, DSO As Object, Cell As Range, k

    Set DSO = CreateObject("Scripting.Dictionary")
    DSO.CompareMode = 1 'case-insensitive
    
    Set ws = ActiveSheet 'or some other sheet...
    For Each Cell In ws.Range("A1", ws.Cells(Rows.Count, "A").End(xlUp)).Cells
        k = Cell.Value & Chr(0) & Cell.EntireRow.Columns("E").Value 'create the key value
        If DSO.exists(k) Then
            Cell.EntireRow.Columns("H").Value = 0
        Else
            DSO.Add k, Cell '.Value ?
        End If
    Next Cell
End Sub

CodePudding user response：

I just added a second dictionary and checked both:

Sub CheckDupes()

    Dim Cell As Range
    Dim DSO1 As Object
    Dim DSO2 As Object
    Dim Rng As Range
    
    Set Rng = Range("A1", Cells(Rows.Count, "A").End(xlUp))
     
    Set DSO1 = CreateObject("Scripting.Dictionary")
    DSO1.CompareMode = 1
    Set DSO2 = CreateObject("Scripting.Dictionary")
    DSO1.CompareMode = 1
     
        For Each Cell In Rng
            If DSO1.Exists(Cell.Text) And DSO2.Exists(Cell.Offset(0, 4).Text) Then
                Cell.Offset(0, 7) = 0
            Else
                If Not DSO1.Exists(Cell.Text) Then _
                    DSO1.Add Cell.Text, Cell
                If Not DSO2.Exists(Cell.Offset(0, 4).Text) Then _
                    DSO2.Add Cell.Offset(0, 4).Text, Cell.Offset(0, 4)
            End If
        Next Cell
    
    Set DSO1 = Nothing
    Set DSO2 = Nothing
    
End Sub

Example: