VBA macro - Delete duplicates with two columns

[johnston]

Hello,

I am trying to create A VBA macro where the user is asked from a input box to select a column for range like "A:A". They are then asked for a second column range, like "C:C" for example.

Once the two ranges are selected I want to have excel compare the two column ranges for duplicates and delete them from the first one.

For example if the user selected column range1 and column range2. And both have cells with the number 5 and 7, I want column range1 to delete all cells that are 5 and 7.

 

[Trebor76]

Hi johnston,

Here's one possible way to try while on the sheet in question (though initially on a copy of your data as the results cannot be undone if they're not as expected):

Option Explicit
Sub Macro1()

    Dim strMyRange() As String
    Dim strInputBoxValue As String
    Dim i As Long, j As Long
    Dim rngShift As Range

    strInputBoxValue = InputBox("Enter the columns to check for duplicates each separated by a comma i.e." & vbNewLine & "A,J", "Delete Duplicates Editor")
    
    If Len(strInputBoxValue) = 0 Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    strMyRange = Split(strInputBoxValue, ",")
    j = Cells(Rows.Count, CStr(strMyRange(0))).End(xlUp).Row
    
    For i = 1 To j
        If Application.WorksheetFunction.CountIf(Range(strMyRange(1) & ":" & strMyRange(1)), Range(strMyRange(0) & i)) > 0 Then
            If rngShift Is Nothing Then
                Set rngShift = Range(strMyRange(0) & i)
            Else
                Set rngShift = Union(rngShift, Range(strMyRange(0) & i))
            End If
        End If
    Next i
    
    'If the 'rngShift' range has been set (i.e. there's something in it), then...
    If Not rngShift Is Nothing Then
        '...delete the cells by shift up to stop rows from the second range being deleted and inform the user.
        rngShift.Delete xlShiftUp
        MsgBox "The duplicates between columns " & StrConv(strMyRange(0), vbUpperCase) & " and " & StrConv(strMyRange(1), vbUpperCase) & " have now been removed from Col. " & StrConv(strMyRange(0), vbUpperCase) & ".", vbInformation, "Delete Duplicates Editor"
    'Else...
    Else
        '...inform the user that no rows are to be deleted as there was no duplicates found.
        MsgBox "There were no duplicates found between columns " & StrConv(strMyRange(0), vbUpperCase) & " and " & StrConv(strMyRange(1), vbUpperCase) & ".", vbExclamation, "Delete Duplicates Editor"
    End If
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Peter_SSs]

I suggest that you update your Account details (or click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)

I want column range1 to delete all cells that are ...

Delete the actual cell and move all other cells up, or just delete the values in the cells?

My code is to just delete the values in the cells.
My code also assumes the values in the first column are not the result of formulas that need to be retained.

Sub Delete_Dupes()
  Dim Cols As String
  Dim Bits As Variant
  Dim r1 As Range, r2 As Range
 
  Cols = InputBox("Enter the columns to check for duplicates each separated by a comma i.e." & vbNewLine & "A,J", "Delete Duplicates Editor")
  If InStr(Cols, ",") > 0 Then
    Bits = Split(Cols, ",")
    On Error Resume Next
    Set r1 = Range(Trim(Bits(0)) & 1, Range(Trim(Bits(0)) & Rows.Count).End(xlUp))
    Set r2 = Range(Trim(Bits(1)) & 1, Range(Trim(Bits(1)) & Rows.Count).End(xlUp))
    On Error GoTo 0
    If Not r1 Is Nothing And Not r2 Is Nothing Then
      r1.Value = Evaluate(Replace("if(#="""","""", if(countif(" & r2.Address & ",#)>0,""^^^^^"",#))", "#", r1.Address))
      r1.Replace What:="^^^^^", Replacement:=""
    End If
  End If
End Sub