比较 A 列和 B 列并创建包含仅存在于 A 列中的值的新列
Compare column A and B and create new column that contains values that only exist in column A
有几个问题提出了类似但不完全相同的问题。
我有两列 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
到目前为止，我录制了一个宏，所以尽管我已尽最大努力清理它，但代码自然非常慢。我不会 post 整个代码，因为它很乱，但基本上我已经
使用 unique() 函数创建了两个列，分别包含 X 和 Y 的唯一值。
使用vlookup()创建了一个与我刚刚创建的两个相邻的列returns一个空字符串
如果相邻的唯一 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
- 已过滤掉
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
抱歉，您不得不阅读那些可怕的代码。我很高兴把所有这些都扔掉。任何帮助将不胜感激。
我看你不介意放手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
写入唯一列
- 调整常量部分中的值。
Download 来自 Google 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
通过用户定义的函数替代Unique2()（相对于 MS 365）
受益于 MS 365 的新动态功能，您可以结合新的（工作表）功能
Unique() （自版本 365 起可用）
和
Application.Match() *（无证同时！两个数组的比较）plus
通过 VBA.Filter() 对要删除的已存在项目进行负过滤。 - 这些通过 IsNumeric() 识别，因为它们 return 在第二个数组中找到的任何位置（而实际搜索的 uniques 将 return 一个错误值，被 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
通过公式输入调用示例[=46=]
输入以下动态 (udf) 公式，例如进入单元格 Z1 以填充整个溢出范围：
=UNIQUE2(X1:X6,Y1:Y4)
有几个问题提出了类似但不完全相同的问题。
我有两列 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 |
到目前为止，我录制了一个宏，所以尽管我已尽最大努力清理它，但代码自然非常慢。我不会 post 整个代码，因为它很乱，但基本上我已经
使用
unique()函数创建了两个列，分别包含X和Y的唯一值。使用
vlookup()创建了一个与我刚刚创建的两个相邻的列returns一个空字符串 如果相邻的唯一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
- 已过滤掉
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
抱歉，您不得不阅读那些可怕的代码。我很高兴把所有这些都扔掉。任何帮助将不胜感激。
我看你不介意放手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
写入唯一列
- 调整常量部分中的值。
Download来自Google 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
通过用户定义的函数替代Unique2()（相对于 MS 365）
受益于 MS 365 的新动态功能，您可以结合新的（工作表）功能
Unique()（自版本 365 起可用）
和
Application.Match()*（无证同时！两个数组的比较）plus通过
忽略VBA.Filter()对要删除的已存在项目进行负过滤。 - 这些通过IsNumeric()识别，因为它们 return 在第二个数组中找到的任何位置（而实际搜索的 uniques 将 return 一个错误值，被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
通过公式输入调用示例[=46=]
输入以下动态 (udf) 公式，例如进入单元格 Z1 以填充整个溢出范围：
=UNIQUE2(X1:X6,Y1:Y4)