比较 A 列和 B 列并创建包含仅存在于 A 列中的值的新列

Question

有几个问题会问类似但不确切的问题。

我有两列 X 和 Y。 Y 仅包含存在于 X 中的值。我想创建一个列Z，其中包含仅存在于X 中的所有值。

• X 和 Y 可以包含重复数据，如示例所示
• X 存在于sheet1 而Y and Z 存在于sheet2

X	Y	Z
a	c	a
b	e	b
b	d
c	e
d
e

到目前为止，我录制了一个宏，因此代码非常慢，尽管我尽了最大努力清理它。我不会发布整个代码，因为它很乱，但基本上我已经

1. 使用unique() 函数创建了两列，分别包含X 和Y 的唯一值。

2. 使用vlookup() 创建与我刚刚创建的两个相邻的列，返回一个空字符串 如果相邻的唯一 X 值存在于唯一的 Y 列中，则返回 X 值。这部分速度非常慢。我在一个单元格中创建了公式，然后将其粘贴下来。

Range("U2").Formula2R1C1 = "=UNIQUE('1.HoldingCart'!C[-18])"
Range("V2").Formula2R1C1 = "=UNIQUE(C[-19])"
Range("W3").FormulaR1C1 = "=IF(ISNA(VLOOKUP(RC[-2], C[-1], 1, FALSE)), RC[-2], """")"
Range("W3").Copy
Range("W3:W" & Cells(Rows.Count, "U").End(xlUp).Row).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

1. 过滤掉vlookup() 列上的所有空字符串。复制了实际值。摆脱了过滤器。删除所有内容，然后粘贴复制的数据，从而创建列Z。

' Get the discrepancies
ActiveSheet.Range("$W:$W").AutoFilter Field:=1, Criteria1:="<>"
Range("W2:W" & Cells(Rows.Count, "W").End(xlUp).Row).Copy
Range("X2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _:=False, Transpose:=False

' Clean the sheet
ActiveSheet.ShowAllData
Selection.AutoFilter
Range("U2:W" & Cells(Rows.Count, "W").End(xlUp).Row).ClearContents

' Paste the discrepancies
Range("X2:X" & Cells(Rows.Count, "X").End(xlUp).Row).Cut
Range("U2").Select
ActiveSheet.Paste

抱歉，您只需要阅读那段可怕的代码。我很高兴把这一切都扔掉。任何帮助将不胜感激。

Answer 1

我看到您不介意放弃 VBA，而是愿意使用公式。使用 microsoft365，您可以使用：

C2中的公式

=UNIQUE(FILTER(A2:INDEX(A:A,MATCH("ZZZ",A:A)),COUNTIF(B2:INDEX(B:B,MATCH("ZZZ",B:B)),A2:INDEX(A:A,MATCH("ZZZ",A:A)))=0))

---

如果您确实想通过 VBA，那么也许使用字典。一个粗略的例子可能是：

Sub Test()

Dim LrA As Long, LrB As Long, x As Long
Dim arrA As Variant, arrB As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")

With ws
    
    'Get last used rows
    LrA = .Cells(.Rows.Count, 1).End(xlUp).Row
    LrB = .Cells(.Rows.Count, 2).End(xlUp).Row
    
    'Initialize arrays
    arrA = .Range("A2:A" & LrA).Value
    arrB = .Range("B2:B" & LrB).Value
    
    'Run over arrA and fill Dictionary
    For x = LBound(arrA) To UBound(arrA)
        dict(arrA(x, 1)) = 1
    Next
    
    'Run over arrB and remove from Dictionary
    For x = LBound(arrB) To UBound(arrB)
        If dict.Exists(arrB(x, 1)) Then dict.Remove arrB(x, 1)
    Next
    
    'Pull remainder from dictionary
    .Cells(2, 3).Resize(dict.Count).Value = dict.Keys
    
End With

End Sub

Answer 2

通过用户定义函数 Unique2() 替代（与 MS 365 相比）

受益于 MS 365 的新动态功能，您可以组合新的（工作表）功能

• Unique() （自版本 365 起可用）

与

• Application.Match() *（未记录的同时！两个数组的比较）加

• 通过VBA.Filter() 对要删除的已存在项目进行负面过滤。 - 这些是通过IsNumeric() 标识的，因为它们返回第二个数组中找到的任何位置（而实际搜索的 uniques 将返回一个错误值，IsNumeric 会忽略该值）

Function UNIQUE2(rng1 As Range, rng2 As Range)
Dim x:   x = Application.Unique(rng1)
Dim y:   y = rng2
Dim tmp: tmp = Application.Transpose(Application.Match(x, y, 0))
Dim i As Long
For i = LBound(tmp) To UBound(tmp)
    tmp(i) = IIf(IsNumeric(tmp(i)), "DELETE", x(i, 1))
Next
UNIQUE2 = Application.Transpose(Filter(tmp, "DELETE", False))
End Function

通过公式输入调用示例

输入以下动态 (udf) 公式，例如进入单元格Z1 以填充整个溢出范围：

    =UNIQUE2(X1:X6,Y1:Y4)    

Answer 3

写入唯一列

• 调整常量部分中的值。
• DownloadGoogle Drive 的工作簿副本（右上角的向下箭头）

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from the Source Column, that are not
'               found in the Lookup Column, to the Destination Column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub writeUniqueColumn()
    Const ProcName As String = "writeUniqueColumn"
    On Error GoTo clearError
    
    Const sName As String = "Sheet1"
    Const sFirst As String = "A2"
    Const lName As String = "Sheet2"
    Const lFirst As String = "A2"
    Const dName As String = "Sheet2"
    Const dFirst As String = "B2"
    
    Dim isDataFound As Boolean
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    Dim sCell As Range: Set sCell = wb.Worksheets(sName).Range(sFirst)
    Dim sData As Variant: sData = getUniqueColumn(sCell)
    If IsEmpty(sData) Then GoTo ProcExit
    
    Dim lCell As Range: Set lCell = wb.Worksheets(lName).Range(lFirst)
    Dim lData As Variant: lData = getUniqueColumn(lCell)
    If IsEmpty(lData) Then GoTo ProcExit
    
    Dim Indexes As Variant: Indexes = Application.Match(sData, lData, 0)
    Dim sCount As Long: sCount = UBound(sData, 1)
    Dim dCount As Long: dCount = sCount - Application.Count(Indexes)
    
    If dCount = 0 Then GoTo ProcExit
        
    Dim dData As Variant: ReDim dData(1 To dCount, 1 To 1)
    Dim s As Long, d As Long
    For s = 1 To sCount
        If IsError(Indexes(s, 1)) Then
            d = d + 1
            dData(d, 1) = sData(s, 1)
        End If
    Next s
    
    Dim dCell As Range: Set dCell = wb.Worksheets(dName).Range(dFirst)
    With dCell
        .Resize(dCount).Value = dData
        .Resize(.Worksheet.Rows.Count - .Row - dCount + 1) _
            .Offset(dCount).ClearContents
    End With
    
    isDataFound = True

ProcExit:
    
    If isDataFound Then
        If dCount = 1 Then
            MsgBox "Found 1 unique value.", vbInformation, "Unique"
        Else
            MsgBox "Found " & dCount & " unique values.", _
                vbInformation, "Unique"
        End If
    Else
        MsgBox "No unique values found", vbExclamation, "No Data"
    End If
    
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Writes the unique values from a one-column range
'               to a 2D one-based array, excluding error and blank values.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function getUniqueColumn( _
    ByVal FirstCell As Range, _
    Optional ByVal Horizontal As Boolean = False) _
As Variant
    Const ProcName As String = "getUniqueColumn"
    On Error GoTo clearError
    
    If Not FirstCell Is Nothing Then
        Dim fCell As Range: Set fCell = FirstCell.Cells(1)
        Dim lCell As Range
        Set lCell = fCell.Resize(fCell.Worksheet.Rows.Count - fCell.Row + 1) _
            .Find("*", , xlFormulas, , , xlPrevious)
        If Not lCell Is Nothing Then
            Dim rg As Range: Set rg = fCell.Resize(lCell.Row - fCell.Row + 1)
            Dim rCount As Long: rCount = rg.Rows.Count
            Dim Data As Variant
            If rCount = 1 Then
                ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
            Else
                Data = rg.Value
            End If
            Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
            dict.CompareMode = vbTextCompare
            Dim Key As Variant
            Dim n As Long
            For n = 1 To rCount
                Key = Data(n, 1)
                If Not IsError(Key) Then
                    If Len(Key) > 0 Then
                        dict(Key) = Empty
                    End If
                End If
            Next n
            If dict.Count > 0 Then
                n = 0
                If Horizontal Then
                    ReDim Data(1 To 1, 1 To dict.Count)
                    For Each Key In dict.Keys
                        n = n + 1
                        Data(1, n) = Key
                    Next Key
                Else
                    ReDim Data(1 To dict.Count, 1 To 1)
                    For Each Key In dict.Keys
                        n = n + 1
                        Data(n, 1) = Key
                    Next Key
                End If
                getUniqueColumn = Data
            End If
        End If
    End If

ProcExit:
    Exit Function
clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit
End Function