Question

我确定这已经在其他地方得到了解答，但我只是找不到（或者得到我发现的对我有用的东西）。 “ A”列是包含许多重复项的列表。在“ B”列中，我对“ A”列中感兴趣的项目放置了“ X”。我想在另一张纸上找到的是唯一值列表，该列表仅列出列表中“ B”中有“ X”的项目。仅值是一个加号。

Answer 1

如果工作表中有标题，则以下内容可能对您有用。

如果工作表没有标题，则可以修改代码，使其首先插入一行。

Option Explicit

Private Sub FilterAndPasteUniques()

    Dim sourceSheet As Worksheet
    Set sourceSheet = ThisWorkbook.Worksheets("Sheet1") ' Change to whatever yours is called

    Dim lastSourceRow As Long
    lastSourceRow = sourceSheet.Cells(sourceSheet.Rows.Count, "A").End(xlUp).Row

    Dim toFilterIncludingHeaders As Range
    Set toFilterIncludingHeaders = sourceSheet.Range("A1", "B" & lastSourceRow)

    toFilterIncludingHeaders.AutoFilter Field:=2, Criteria1:="X"

    Dim cellsToCopy As Range
    On Error Resume Next
    Set cellsToCopy = toFilterIncludingHeaders.Offset(1).Resize(toFilterIncludingHeaders.Rows.CountLarge - 1, 1).SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If Not (cellsToCopy Is Nothing) Then
        cellsToCopy.Copy

        Dim destinationSheet As Worksheet
        Set destinationSheet = ThisWorkbook.Worksheets("Sheet2") ' Change to whatever yours is called

        With destinationSheet.Range("A1")
            .PasteSpecial xlPasteValuesAndNumberFormats
            .Resize(cellsToCopy.Rows.CountLarge, cellsToCopy.Columns.CountLarge).RemoveDuplicates Columns:=1, Header:=xlNo
        End With
    End If

    sourceSheet.AutoFilterMode = False
    Application.CutCopyMode = False

End Sub

根据另一列中的值提取唯一值以分隔工作表

1 个答案: