Excel: сравнить два диапазона и удалить дублирующиеся значения ячеек

Question

У меня есть два диапазона данных:

• Range1 - список доступных имен проектов
• Range2 - список имен проектов, которые используются

Я пытаюсь написать код VBA, который будет сравнивать эти два диапазона, и если какое-либо значение существует в Range1, но не в Range2, то я хочу удалить это значение из Range1.

У меня естьследующий код, но в настоящее время он удаляет все в Range1, независимо от того, находятся ли имена проектов в 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

Как этого достичь?

Answer 1

вы можете использовать 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 2

Это похоже на работу

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 3

У вас может быть эта функция на стандартном модуле ...

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

Затем вы можете вызвать эту функцию из вашего макроса, как показано ниже.

Не забудьте установить Rng1 и Rng2 согласно вашему требованию перед вызовом функции.

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