Delete both duplicate entries across two columns

[PaulWJ]

I have a sheet where I've got dates in two columns. First column shows dates available, second column shows dates used. I want to run a macro to remove the same date from both columns. The dates won't necessarily be in the same row in each column.

i.e. In the example sheet shown, 24/12/24 was available, and has been used, so I want to delete it from both columns so the Available Dates column shows only dates that haven't been used. Apologies, but I'm not able to load the example due to IT permissions.

The data is in Columns BA and BB as in the example, and extends down from Row 2 to Row 100. I've tried quite a few options that I've found, but they either don't work, or I've not understood them well enough to make them work. Any help is appreciated.

 

[saboh12617]

Hello,

Maybe it looks a bit heavy but this script should remove any duplicates in both columns quickly. You can adapt it by changing the columns first cells at the top of the code. The rest will adapt. Using ArrayLists and Dictionary as you are on Windows.

Public Sub RemoveDups()
  ' adaptable
  Dim avRngTop As Range: Set avRngTop = Range("BA2")
  Dim upRngTop As Range: Set upRngTop = Range("BB2")
 
  Dim avVals As Variant
  With Range(avRngTop, avRngTop.End(xlDown))
    avVals = .Value2
    .ClearContents
  End With
  Dim upVals As Variant
  With Range(upRngTop, upRngTop.End(xlDown))
    upVals = .Value2
    .ClearContents
  End With
 
  Dim v As Variant
  Dim avDate As Object: Set avDate = CreateObject("System.Collections.ArrayList")
  For Each v In avVals
    avDate.Add v
  Next v
  Dim udDate As Object: Set udDate = CreateObject("System.Collections.ArrayList")
  For Each v In upVals
    udDate.Add v
  Next v
 
  Dim duplicates As Object
  Set duplicates = CreateObject("Scripting.Dictionary")
  For Each v In avDate
    If udDate.Contains(v) Then duplicates.Add v, Nothing
  Next v
 
  Dim dupl As Variant
  For Each dupl In duplicates.Keys()
    Do While avDate.Contains(dupl)
      avDate.Remove dupl
    Loop
    Do While udDate.Contains(dupl)
      udDate.Remove dupl
    Loop
  Next dupl
 
  With avRngTop.Resize(avDate.Count, 1)
    .Value2 = WorksheetFunction.Transpose(avDate.ToArray)
    .NumberFormat = avRngTop.NumberFormat
  End With
  With upRngTop.Resize(udDate.Count, 1)
    .Value2 = WorksheetFunction.Transpose(udDate.ToArray)
    .NumberFormat = upRngTop.NumberFormat
  End With
End Sub

 

[PaulWJ]

Hello,

Maybe it looks a bit heavy but this script should remove any duplicates in both columns quickly. You can adapt it by changing the columns first cells at the top of the code. The rest will adapt. Using ArrayLists and Dictionary as you are on Windows.

Public Sub RemoveDups()
  ' adaptable
  Dim avRngTop As Range: Set avRngTop = Range("BA2")
  Dim upRngTop As Range: Set upRngTop = Range("BB2")
 
  Dim avVals As Variant
  With Range(avRngTop, avRngTop.End(xlDown))
    avVals = .Value2
    .ClearContents
  End With
  Dim upVals As Variant
  With Range(upRngTop, upRngTop.End(xlDown))
    upVals = .Value2
    .ClearContents
  End With
 
  Dim v As Variant
  Dim avDate As Object: Set avDate = CreateObject("System.Collections.ArrayList")
  For Each v In avVals
    avDate.Add v
  Next v
  Dim udDate As Object: Set udDate = CreateObject("System.Collections.ArrayList")
  For Each v In upVals
    udDate.Add v
  Next v
 
  Dim duplicates As Object
  Set duplicates = CreateObject("Scripting.Dictionary")
  For Each v In avDate
    If udDate.Contains(v) Then duplicates.Add v, Nothing
  Next v
 
  Dim dupl As Variant
  For Each dupl In duplicates.Keys()
    Do While avDate.Contains(dupl)
      avDate.Remove dupl
    Loop
    Do While udDate.Contains(dupl)
      udDate.Remove dupl
    Loop
  Next dupl
 
  With avRngTop.Resize(avDate.Count, 1)
    .Value2 = WorksheetFunction.Transpose(avDate.ToArray)
    .NumberFormat = avRngTop.NumberFormat
  End With
  With upRngTop.Resize(udDate.Count, 1)
    .Value2 = WorksheetFunction.Transpose(udDate.ToArray)
    .NumberFormat = upRngTop.NumberFormat
  End With
End Sub

Thanks for this, but it doesn't seem to work for me. The first bit (from Dim avVals As Variant) actually clears out all the data in the two columns. I'm also getting an error message (possibly because of this?)

 

[saboh12617]

Oh yes, stupid error I did, change this yellow row with the code below

If udDate.Contains(v) Then duplicates(v) = Nothing

The original range is indeed deleted, and then reformed with only not-duplicated values that are saved in the Sub. It is easier to do things like this.
Please correct the code, put back your datas and try again, thank you.
Apologies.

 

[PaulWJ]

Thanks for the reply, and the explanation. I do have some knowledge of VBA, but this is beyond my level.

If replaced the code, but now get a different error - but at the same point

 

[saboh12617]

I'm a bit rusty,
Sorry, the final and correct answer is this one. Apologies again for the lost time

If udDate.Contains(v) And (Not duplicates.exists(v)) Then duplicates.Add v, Nothing

Make sure to add datas before lauching the Sub again (or it will go to bottom of the column).

 

[PaulWJ]

There's no need to apologise, I really appreciate the help. That bit runs fine now (and gives the results I expected), but getting another error need the bottom of the macro.

 

[saboh12617]

Please find below a revision, i did not take into account the fact that the resulting columns could be empty (all duplicata) and therefore the code struggles.

Public Sub RemoveDups()
  ' adaptable
  Dim avRngTop As Range: Set avRngTop = Range("BA2")
  Dim upRngTop As Range: Set upRngTop = Range("BB2")
 
  Dim avVals As Variant
  With Range(avRngTop, avRngTop.End(xlDown))
    avVals = .Value2
    .ClearContents
  End With
  Dim upVals As Variant
  With Range(upRngTop, upRngTop.End(xlDown))
    upVals = .Value2
    .ClearContents
  End With
 
  Dim v As Variant
  Dim avDate As Object: Set avDate = CreateObject("System.Collections.ArrayList")
  For Each v In avVals
    avDate.Add v
  Next v
  Dim udDate As Object: Set udDate = CreateObject("System.Collections.ArrayList")
  For Each v In upVals
    udDate.Add v
  Next v
 
  Dim duplicates As Object
  Set duplicates = CreateObject("Scripting.Dictionary")
  For Each v In avDate
    If udDate.Contains(v) And (Not duplicates.exists(v)) Then duplicates.Add v, Nothing
  Next v
 
  Dim dupl As Variant
  For Each dupl In duplicates.Keys()
    Do While avDate.Contains(dupl)
      avDate.Remove dupl
    Loop
    Do While udDate.Contains(dupl)
      udDate.Remove dupl
    Loop
  Next dupl
  
  If avDate.Count > 0 Then
    With avRngTop.Resize(avDate.Count, 1)
      .Value2 = WorksheetFunction.Transpose(avDate.ToArray)
      .NumberFormat = avRngTop.NumberFormat
    End With
  End If
  If udDate.Count > 0 Then
    With upRngTop.Resize(udDate.Count, 1)
      .Value2 = WorksheetFunction.Transpose(udDate.ToArray)
      .NumberFormat = upRngTop.NumberFormat
    End With
  End If
End Sub

 

[PaulWJ]

Smashing. That's it perfect now. I'd never have been able to do that myself - really appreciate it.

 

[saboh12617]

Glad to hear that it works!
Happy to help, have a good day.