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

结束子

如何做到这一点？

Answer 1

您可以在标准模块上使用此功能...

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

Answer 2

你可以使用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

这似乎有效

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