突出显示电子表格中具有一定数量匹配列值的行[关闭]

Question

我目前正在努力解决这个问题。我试图实现的目标是如何将最相似的行组合在一起。设置：所有行相互独立，但它们可以在同一行中有任意数量的列值（最多 10 个）。我正在寻找一种解决方案来帮助我在 10 列中找到具有 3 个或更多共同值的行并相应地突出显示它们。我刚刚进入 excel VBA，我觉得这是我需要前进的方向。我将提供一组简化的数据，我想这样做。在图片中，我试图实现的目标是将第 8 行和第 10 行“分组”在一起，因为它们有 3 个或更多列匹配。任何帮助将不胜感激！

更新：我无法提供实际使用的数据，但脚本需要能够处理字母数字值（例如：MELP7899797）。感谢您的帮助！！！！

Answer 1

请尝试此代码。请注意，您必须在顶部设置常量 TopLeftCell 以告诉宏您的数据在哪里。在您的示例中，左上角的单元格是 A1。我用数据上方的空白行进行了测试，因此左上角在 A2 中。

Sub MarkMatches()
    ' 033

    Const TopLeftCell As String = "A2"      ' change to match where your data are

    Dim Rng As Range                        ' data range
    Dim FirstRow As Long, FirstClm As Long
    Dim Data As Variant                     ' original data (2-D)
    Dim Arr As Variant                      ' data rearranged (1-D)
    Dim Tmp As Variant                      ' working variable
    Dim R As Long, R1 As Long               ' row counters
    Dim C As Long                           ' column counter
    Dim Count() As String                   ' match counter

    With Range(TopLeftCell)
        FirstRow = .Row
        FirstClm = .Column
    End With
    C = Cells(FirstRow, Columns.Count).End(xlToLeft).Column
    Set Rng = Range(Cells(FirstRow, FirstClm), _
                    Cells(Rows.Count, FirstClm).End(xlUp).Offset(0, C - FirstClm))
    Data = Rng.Value

    ReDim Arr(1 To UBound(Data))
    For R = 1 To UBound(Data)
        ReDim Tmp(1 To UBound(Data, 2))
        For C = 1 To UBound(Data, 2)
            Tmp(C) = Data(R, C)
        Next C
        Arr(R) = Tmp
    Next R

    ReDim Count(1 To UBound(Arr))
    For R = 1 To UBound(Arr) - 1
        For R1 = R + 1 To UBound(Arr)
            Tmp = 0
            For C = 1 To UBound(Arr(R))
                If Not IsError(Application.Match(Arr(R)(C), Arr(R1), 0)) Then
                    Tmp = Tmp + 1
                End If
            Next C
            If Tmp > 0 Then                 ' change to suit
                Tmp = Format(Tmp, "(0)") & ", "
                Count(R) = Count(R) & CStr(R1 + FirstRow - 1) & Tmp
                Count(R1) = Count(R1) & CStr(R + FirstRow - 1) & Tmp
            End If
        Next R1
    Next R

    For R = 1 To UBound(Count)
        If Len(Count(R)) Then Count(R) = Left(Count(R), Len(Count(R)) - 2)
    Next R
    ' set the output column here (2 columns right of the last data column)
    '   to avoid including this column in the evaluation
    '   it must be blank before a re-run
    Set Rng = Rng.Resize(, 1).Offset(0, UBound(Data, 2) + 1)
    Rng.Value = Application.Transpose(Count)
End Sub

代码将产生如下所示的结果并将其写入数据右侧的空白列。 （请注意，代码假定工作表中的所有数据都用于评估，TopLeftCell 上方或左侧的数据除外）。

阅读 4(4)（在第一行，即工作表的第 2 行）表示与第 4 行相比有 4 个匹配项。在第 4 行中，您将找到匹配信息, 2(4) 表示第 2 行有 4 个匹配项。结果显示除零之外的所有匹配项。此结果由这行代码控制。

If Tmp > 0 Then                 ' change to suit

如果您将其更改为 Tmp => 3，您可以排除噪音。当然，结果也可以以完全不同的方式应用。但是，简单地为匹配的行着色是行不通的。如您所见，有很多符合条件的行，对所有行应用颜色会隐藏现在可用的信息，即哪些行与哪些其他行匹配。