电子表格中突出显示的行，其具有与列值匹配的特定数字

Question

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

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

，则可以排除噪声。当然，结果也可以以完全不同的方式应用。但是，仅对匹配的行进行着色不会。如您所见，有很多合格行，并且对所有行应用颜色会隐藏现在可用的信息，即哪些行与其他行匹配。