Question

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

我已经弄清楚了如何删除重复的行，但是我想弄清楚该如何做相反的事情。我想删除任何没有重复的行。我想保留重复一次或多次的行的副本。例如，如果我有一个单行的行：

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

Answer 1

这是如何隔离在某个范围内重复的单元格的一般示例。设置Range.Resize变量时，可以使用Duplicates方法扩展复制范围。

在照片中，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

Excel VBA：清除所有未重复的行

1 个答案: