Excel VBA：删除所有不重复的行答案

【问题标题】：Excel VBA: Erase all rows that AREN'T duplicatedExcel VBA：删除所有不重复的行
【发布时间】：2019-01-16 05:52:33
【问题描述】：

vba 新手在这里。我编写了一个程序，它创建一个新的 Excel 文件，并根据用户输入的搜索词复制几行数据。如果用户正在搜索多个文本字符串，他/她可以在每个字符串之间选择“或”或“与”。因此，如果用户输入“Apples OR Pears”，程序将输出任何有苹果或有梨的数据。如果用户输入“Apples AND pears”，程序将输出包含苹果和梨的任何数据。

我已经想出了如何删除重复的行，但我想弄清楚如何做 OPPOSITE。我想删除任何没有重复的行。我想保留一份重复一次或多次的行的副本。例如，如果我有一个单列行阅读：

Apples
Oranges
Pears
Apples
Cherries
Pears

我希望宏删除行，以便新列表显示为：

Apples
Pears

我希望以不需要复制到多张工作表的方式运行宏。这是因为我试图找出的代码将在 For 循环中使用，这可能会变得复杂运行多次。

这是我现在的代码。我已经评论了我想在哪里插入这部分代码：

    Dim srchLen, myString As Integer
    Dim nxtRw As Long
    Dim firstAddress As String
    Dim c As Range
    Dim rng As Range
    Dim SearchRange As Range
    Dim wbSearchTool As Workbook
    Dim wbSearchResults As Workbook

    'Create and format a new workbook for search results
    Set wbSearchTool = ThisWorkbook
    Set wbSearchResults = Workbooks.Add(xlWBATWorksheet)
    wbSearchResults.Sheets("Sheet1").Range("B:C").NumberFormat = "mm/dd/yyyy"
    wbSearchResults.Sheets("Sheet1").Range("B:R").WrapText = True
    wbSearchResults.Sheets("Sheet1").Range("B:R").HorizontalAlignment = xlLeft
    wbSearchResults.Sheets("Sheet1").Range("A1:R1").Font.Bold = True
    With wbSearchResults.Sheets("Sheet1")
        .Columns("A:F").ColumnWidth = 10
        .Columns("G").ColumnWidth = 16.5
        .Columns("H:I").ColumnWidth = 35
        .Columns("J:R").ColumnWidth = 15
    End With

    'Copy Column Headings from Data
     wbSearchResults.Sheets("Sheet1").Rows(1) = wbSearchTool.Sheets("Data").Rows(1).Value

    'Determine length of Search Criteria Column from Search Sheet
        wbSearchTool.Activate
        srchLen = Sheets("Search").Range("C2").End(xlDown).Row

    'Loop through list in Search, Column C. As each value is
    'found in Data, Column F, copy it to the next row in Search Results

        If srchLen = 3 Then
        Else
        For myString = 4 To srchLen
            Set SearchRange = Sheets("Data").Range(Sheets("Search").Range("F" & myString).Value)
            With SearchRange
                Set c = .Find(Sheets("Search").Range("C" & myString), lookat:=xlPart)
                  If Not c Is Nothing Then
                   firstAddress = c.Address
                    Do
                      nxtRw = wbSearchResults.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row + 1
                      wbSearchResults.Sheets("Sheet1").Range("A" & nxtRw & ":R" & nxtRw) = wbSearchTool.Sheets("Data").Range("A" & c.Row & ":R" & c.Row).Value
                      Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> firstAddress
                  End If
            End With

            'THIS IS WHERE I WANT CODE TO ONLY KEEP DUPLICATES!!!

        Next
        End If

【问题讨论】：

请重新编写代码示例以将其减少到仅需要的部分。
老实说，这是我认为与尝试理解我正在尝试做的事情相关的简化代码，哈哈。如果有人仅使用“或”选项进行搜索，则此代码当前有效。因此，如果有人搜索“Apples OR Pears OR Oranges”，则此代码会创建一个新工作簿，搜索数据并复制包含“apples”的任何行，然后搜索数据并复制包含“Pears”的任何行，然后“橘子。”最后，在您在这里看不到的代码中，我删除了所有重复项......因此输出每行的一个副本，其中包含苹果、梨或橙子。
但是，如果有人想搜索“Apples AND Pears OR Oranges”，那么我需要嵌套在所示的 For 循环中，代码将输出所有包含苹果的行，然后输出所有包含梨的行，然后只保留重复的行（因此同时包含苹果和梨），然后输出所有包含橙子的行。
请edit您的问题，而不是添加 cmets。最初可能不会显示所有 cmets。通过将所有相关信息放在一个地方，您可以更轻松地为您提供帮助。考虑将您的代码缩减为 minimal reproducible example --- 单元格格式在这里只是噪音。

标签： excel vba duplicates

【解决方案1】：

下面是一个通用示例，说明如何隔离区域中重复的单元格。设置Duplicates变量时，可以使用Range.Resize方法扩展复制范围。

在照片中，Column A 是原始数据，Column B 是宏输出。

Option Explicit

Sub Dups()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim SearchRange As Range: Set SearchRange = ws.Range("A1:A6")
Dim CurrentCell As Range, Duplicates As Range

For Each CurrentCell In SearchRange
    If WorksheetFunction.CountIf(SearchRange, CurrentCell) > 1 Then
        If Not Duplicates Is Nothing Then
            Set Duplicates = Union(Duplicates, CurrentCell)
        Else
            Set Duplicates = CurrentCell
        End If
    End If
Next CurrentCell

Duplicates.Copy ws.Range("B1")
ws.Range("B:B").RemoveDuplicates 1, xlNo

End Sub

【讨论】：

谢谢！我稍后会试试这个。