Excel: Compare two ranges and delete duplicate cell values

Question

I have two ranges of data:

• Range1 is a list of available project names
• Range2 is a list of project names that are in use

I'm trying to write VBA code that will compare these two ranges, and if any value exists in Range1, but not in Range2, then I want to delete that value from Range1.

I have the following code so far, but it currently deletes everything in Range1, whether or not the project names are in Range2.

Public Sub CleanProjectLists()

Dim CellinProjectList As Range
Dim CellinCarArea As Range

Dim ProjectColumn As Long

Dim LastrowCarArea As Integer
Dim LastrowProjectList As Integer

Set CheckSheet = Sheets("Engine Ancillaries")
ProjectColumn = 8

LastrowProjectList = Sheets("VBA_Data").Cells(Rows.Count, 
ProjectColumn).End(xlUp).Row
LastrowCarArea = CheckSheet.Cells(Rows.Count, 2).End(xlUp).Row

    For Each CellinCarArea In CheckSheet.Range("B9:B" & LastrowCarArea)
        For Each CellinProjectList In Sheets("VBA_Data").Range(Sheets("VBA_Data").Cells(2, ProjectColumn), Sheets("VBA_Data").Cells(LastrowProjectList, ProjectColumn))
                    If CellinCarArea.Value <> CellinProjectList.Value Then
                        Sheets("VBA_Data").Select
                        CellinProjectList.Offset(0, -1).Select
                        ActiveCell.Resize(, 4).ClearContents
                        Exit For
                        End If
        Next CellinProjectList
    Next CellinCarArea

End Sub

How can this be achieved?

Answer 1

This seems to work

Set CarArea = Sheets("Engine Ancillaries")
ProjectColumn = 8
LastrowJobslist = CarArea.Cells(Rows.Count, 2).End(xlUp).Row
LastrowProjectList = Sheets("VBA_Data").Cells(Rows.Count, 
ProjectColumn).End(xlUp).Row
Set Jobslist = CarArea.Range(CarArea.Cells(9, 2), 
CarArea.Cells(LastrowJobslist, 2))
Set ProjectList = Sheets("VBA_Data").Range(Sheets("VBA_Data").Cells(2, 
ProjectColumn), Sheets("VBA_Data").Cells(LastrowProjectList, ProjectColumn))
For Each CellinProjectList In ProjectList
    ProjectListValue = CellinProjectList.Value
    NoDuplicates = Application.WorksheetFunction.CountIf(Jobslist, ProjectListValue)
    If NoDuplicates = 0 Then
        CellinProjectList.ClearContents
        CellinProjectList.Offset(0, -1).ClearContents
        CellinProjectList.Offset(0, 1).ClearContents
        CellinProjectList.Offset(0, 2).ClearContents
    End If
Next CellinProjectList
Range(Sheets("VBA_Data").Cells(2, ProjectColumn - 1), 
Sheets("VBA_Data").Cells(LastrowProjectList, ProjectColumn + 2)).Sort 
key1:=Sheets("VBA_Data").Range(Sheets("VBA_Data").Cells(2, ProjectColumn), 
Sheets("VBA_Data").Cells(LastrowProjectList, ProjectColumn)), _
order1:=xlAscending, Header:=xlNo

Answer 2

you could use AutoFilter():

Public Sub CleanProjectLists()    
    Dim filters As Variant
    With Sheets("Engine Ancillaries")
        filters = Application.Transpose(.Range("B9", .Cells(.Rows.Count, "B").End(xlUp)).Value) ' collect "Engine Ancillaries" column B values from row 9 down to last not empty row
    End With

    Dim ProjectColumn As Long
    ProjectColumn = 8
    Dim filteredRng As Range
    With Sheets("VBA_Data") 'reference "VBA_Data" sheet
        With .Range(.Cells(1, ProjectColumn), .Cells(.Rows.Count, ProjectColumn).End(xlUp)) ' reference referenced sheet 'ProjectColumn' column cells from row 2 down to last not empty one
            .AutoFilter Field:=1, Criteria1:=filters, Operator:=xlFilterValues ' filter referenced range with values from "Engine Ancillaries" sheet column B
            If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set filteredRng = .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible) ' if any filtered cells collect them in 'filteredRng' range
            .Parent.AutoFilterMode = False ' remove filters
            If filteredRng.Address = .Resize(.Rows.Count - 1).Offset(1).Address Then Exit Sub ' if all cells values were in 'filters' then no cells are to be cleared
            filteredRng.EntireRow.Hidden = True 'hide cells whose values were in "Engine Ancillaries" sheet column B
            .Offset(1, -1).Resize(.Rows.Count - 1, 4).SpecialCells(xlCellTypeVisible).EntireRow.ClearContents ' clear visible cells (i.e. those cells whose value was not in "Engine Ancillaries" sheet column B)
            filteredRng.EntireRow.Hidden = False ' un-hide rows
        End With
    End With
End Sub

Answer 3

You may have this Function on a Standard Module...

Function DeleteFromRange1(ByVal Rng1 As Range, ByVal Rng2 As Range) As Variant
Dim x, y, z(), dict
Dim i As Long, j As Long

Set dict = CreateObject("Scripting.Dictionary")
x = Rng1.Value
y = Rng2.Value

For i = 1 To UBound(y, 1)
    dict.Item(y(i, 1)) = ""
Next i

For i = 1 To UBound(x, 1)
    If dict.exists(x(i, 1)) Then
        j = j + 1
        ReDim Preserve z(1 To j)
        z(j) = x(i, 1)
    End If
Next i
DeleteFromRange1 = z
End Function

Then you may call this function from your macro like below.

Don't forget to set the Rng1 and Rng2 as per your requirement before calling the function.

Sub CleanProjectLists()
Dim Rng1 As Range, Rng2 As Range
Dim arr

Application.ScreenUpdating = False

'Set your Range1 here
'Set Rng1 = .....

'Set your Range2 here
'Set Rng2 = .....

'Then call this function
arr = DeleteFromRange1(Rng1, Rng2)
Rng1.Clear
Rng1.Cells(1).Resize(UBound(arr), 1).Value = Application.Transpose(arr)
Application.ScreenUpdating = True
End Sub