VBA - 查找副本并比较其中哪一个最高

Question

嘿我正在尝试过滤/匹配我的表单重复，我有两个标准：

1. 在(column B)中的任何地方查找重复项，如果在(column E)中与找到的重复项相同的行中设置了“适用”的重复项。
2. 在(column B)中具有最高数量的(column C)中的一个副本（数字在0-10之间）应该仍然在(column E)中具有“适用”但是最低数字应该在(column E)中被“删除”。我希望我看起来像这样：

Sub FindDUB()
    Dim lastRow As Long 'Declaring the lastRow variable

    Dim MatchReqprodID As Long 'store the match index values of the given value
    Dim MatchRevision As Double 'store the match index values of the given value

    Dim RevisionColumnCompare As Integer 'Column number in sheet
    Dim ReqprodIDColumnCompare As Integer 'Column number in sheet

    Dim CompareReqprodID As Long 'Compare is to loop through all the records in the column using For loop
    Dim CompareRevision As Long 'Compare is to loop through all the records in the column using For loop

    RevisionColumnCompare = 3 'C
    ReqprodIDColumnCompare = 2 'B

    'Finding the last row in Reqprod ID
    lastRow = Range("B" & Rows.Count).End(xlUp).Row

    'looping through the Reqprod ID column
    For CompareReqprodID = 1 To lastRow



        If Cells(CompareReqprodID, ReqprodIDColumnCompare) <> "" Then 'skipping if it is blank.

            'getting match index number for the value of the cell
            MatchReqprodID = WorksheetFunction.Match(Cells(CompareReqprodID, ReqprodIDColumnCompare), Range("B1:B" & lastRow), 0)
            'MatchRevision = Application.WorksheetFunction.Large(RevisionColumnCompare, 1)

            'if the match index is not equals to current row number, then it is a duplicate value
            If CompareReqprodID <> MatchReqprodID Then
                'If CompareRevision <> MatchRevision Then
                   ' Cells(CompareReqprodID, ApplicableColumn) = "Removed"
                   ' Cells(MatchReqprodID, ApplicableColumn) = "Applicable"
                'Else
                    Cells(CompareReqprodID, ApplicableColumn) = "Applicable"
                    Cells(MatchReqprodID, ApplicableColumn) = "Removed"
                'End If

            End If

        End If

    Next

End Sub

这段代码不稳定，现在不起作用，如果删除了MatchRevision和If CompareRevision <> MatchRevision Then函数，它就可以使用了。然后我可以找到重复项，但不能指出其中哪一个具有最高版本。

所以我的问题是，如果我可以如何过滤我的工作表，找到重复项，并查看具有最高“修订”值的两个重复项，并将最高设置为“适用”，最低设置为“已删除” “在”状态“。谢谢！

Answer 1

Sub FindDUB()

    Dim lastRow As Long
    Dim currentRow As Long
    Dim innerRow As Long
    Dim frequency As Integer
    Dim currentID As Long
    Dim currentValue As Long
    Dim firstValue As Long

    lastRow = ThisWorkbook.Worksheets("Tabelle1").Range("B" & Rows.Count).End(xlUp).Row

    For currentRow = 1 To lastRow
        frequency = Application.WorksheetFunction.CountIf(Range("B:B"), Range("B" & currentRow).Value)
        If frequency > 1 Then
            Range("E" & currentRow).Value = "Removed"
        Else
        End If
    Next currentRow

    For currentRow = 1 To lastRow
        If Range("E" & currentRow).Value = "Removed" Or Range("E" & currentRow).Value = "Applicable" Then

            currentID = CLng(Range("B" & currentRow).Value)
            firstValue = CLng(Range("C" & currentRow).Value)

            For innerRow = currentRow To lastRow
                If CLng(Range("B" & innerRow).Value) = currentID Then
                    If CLng(Range("C" & innerRow).Value) < firstValue Then
                        Range("E" & currentRow).Value = "Applicable"
                        Range("E" & innerRow).Value = "Removed"
                    ElseIf CLng(Range("C" & innerRow).Value) > firstValue Then
                        Range("E" & currentRow).Value = "Removed"
                        Range("E" & innerRow).Value = "Applicable"
                    Else
                    End If
                Else
                End If
            Next innerRow

        Else
        End If

    Next currentRow


End Sub

Answer 2

如果你想使用公式做到这一点，那么你可以做以下，但请注意，这是非常手动的。

首先，我创建了一些示例数据如下：

A    B          C           D
     ReqProdId  Revision    Owner
     12         2           sis
     34         4           sis
     38         1           hbv
     12         3           sis
     12         4           sis
     34         9           sis
     37         4           hbv

因此，列A中没有任何内容，B列是您的产品ID，C列是您的修订号，D列是所有者。您的实际数据从第2行开始。

然后我添加了E = Status，F = Max和G = Min的列标题。

您在单元格F2中键入的列F的公式是=MAX(IF(B:B=B2,C:C))，但您必须按Ctrl-Shift-Enter才能添加此公式。

您在单元格G2中键入的列G的公式是=MIN(IF(B:B=B2,C:C))，但需要使用Ctrl-Shift-Enter输入，以使其正常工作。

将列F和G的公式向下拖动到数据末尾，它们应填充每组的最低/最高版本号。

从这里我们可以最后添加公式来填充Status列，它作为=IF(F2=G2, "", IF(C2=G2,"Removed",IF(C2=F2,"Applicable","")))进入单元格E2。通过简单的Enter，可以正常输入此公式。然后还需要复制到数据表的末尾。

所以逻辑（如果还不清楚）如下：

• 确定每个组的最小修订号;
• 确定每个组的最大修订号;
• 如果最小和最大数字相同则没有重复，因此将状态设置为空白;
• 如果当前修订号与最小号匹配，那么这是该组中的最低值，因此将状态设置为“已删除”;
• 如果当前修订号与最大数匹配，那么这是该组中的最高值，因此将状态设置为“适用”;
• 在所有其他情况下，它位于组的最大和最小数字之间，因此将状态设置为空白。

我做了这个测试，它工作正常，但手动复制公式并不理想。

---

忘了添加我的结果：

A    B          C           D        E           F      G
     ReqProdId  Revision    Owner    Status      Max    Min
     12         2           sis      Removed     4      2
     34         4           sis      Removed     9      4
     38         1           hbv                  1      1
     12         3           sis                  4      2
     12         4           sis      Applicable  4      2
     34         9           sis      Applicable  9      4
     37         4           hbv                  4      4

Answer 3

尝试使用Dictionary lib。

您需要添加对“Microsoft Scripting Runtime”的引用（工具 - >引用）

sub FindDUB()

    dim row, lastRow, firstRow, Id as Long

    dim checkedId as Dictionary

    Dim ApplicableColumn As Integer 'Column number in sheet
    Dim RevisionColumnCompare As Integer 'Column number in sheet
    Dim ReqprodIDColumnCompare As Integer 'Column number in sheet

    ApplicableColumn = 5 'E
    RevisionColumnCompare = 3 'C
    ReqprodIDColumnCompare = 2 'B

    set checkedId = new Dictionary

    firstRow = 'SET HERE THE FIRST ROW OF DATA RANGE IN YOUR COLUMN
    lastRow = Range("B" & Rows.Count).End(xlUp).Row

    for row = firstRow to lastRow

        id = Cells(row,ReqprodIDColumnCompare).value

        if checkedId.exists(id) then

           'Don't know if you want to compare also EQUALS cells, change as you want it.
            if Cells(checkedId(id),RevisionColumnCompare).value < Cells(row,RevisionColumnCompare).value

            Cells(checkedId(id),ApplicableColumn).value = "Removed"

            checkedId(id).value = row

        else

            checkedId.add id, row

        end if

    next

    dim key

    for each key in checkedId.keys

        Cells(checkedId(key),ApplicableColumn).value = "Applicable"

    next

end sub

Answer 4

我认为这个数组公式会这样做（使用Ctrl，Shift和Enter，大括号将出现在Richard的答案中）。

=IF(COUNTIF($B$2:$B$7,B2)>1,IF(C2=MAX(IF($B$2:$B$7=B2,$C$2:$C$7)),"Applicable","Removed"),"")