删除相似的行

Question

我有300个行的3个单词短语列表。如果任何其他行包含2个相同的单词，我需要删除每一行。例如

Word1 word2 word3
word1 word2 word4 - delete
word1 word2 word5 - delete
word1 word6 word7 - keep, only 1 matching words compared to earlier rows

有没有办法做到这一点？

Answer 1

第1步。使用文字到列或公式将单词分成三列（A，B和C）

第2步。在D，E和F列中，通过以下公式创建所有双字组合：

=A1&B1
=B1&C1
=A1&C1

第3步。将以下公式放入G1并通过H和I列以及所有行填充：

=SUM(COUNTIF(OFFSET($D$1,0,0,ROW(D1),1),D1),COUNTIF(OFFSET($E$1,0,0,ROW(E1),1),D1),COUNTIF(OFFSET($F$1,0,0,ROW(F1),1),D1))-COUNTIF($D1:$F1,D1)

电子表格现在应该看起来像这个截图（除了我添加到最后的两行）：

所有包含两个与上一行中两个单词匹配的单词的行在G，H或I列中的值都大于0.

第4步。最后，按行G，H和I等于0过滤整个表格。如果需要，可以将字词复制并过去（按值）到另一张表格。

Answer 2

这三个单词短语是在单独的单元格中还是都在同一个单元格中。

如果它们位于不同的单元格中，您可以使用此宏：

Option Explicit
Sub DeleteDups()
    Dim colPhrase As Collection
    Dim colRows As Collection
    Dim V As Variant, vRes() As Variant
    Dim I As Long, J As Long
    Dim lDupCount As Long

    Dim rRes As Range 'results range

V = Worksheets("sheet1").Range("a1", Cells(Rows.Count, "C").End(xlUp))
Set colPhrase = New Collection
Set colRows = New Collection

Set rRes = Range("e1")

'look for dups
For I = 1 To UBound(V)
    lDupCount = 0
    On Error Resume Next
    For J = 1 To 3
        colPhrase.Add Item:=CStr(V(I, J)), Key:=CStr(V(I, J))
        If Err.Number <> 0 Then lDupCount = lDupCount + 1
        Err.Clear
    Next J
    On Error GoTo 0
    If lDupCount < 2 Then colRows.Add Item:=CStr(I)
Next I

ReDim vRes(1 To colRows.Count, 1 To 3)
For I = 1 To colRows.Count
    For J = 1 To 3
        vRes(I, J) = V(colRows(I), J)
    Next J
Next I

Set rRes = rRes.Resize(UBound(vRes), 3)
rRes.EntireColumn.Clear
rRes = vRes

End Sub

如果它们在同一个单元格中，根据短语的分隔方式，您只需要添加一行将它们分成三个数组元素。