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

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

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

Excel：比较两个范围并删除重复的单元格值

3 个答案: