高级过滤器在创建的列表的开头和结尾都返回一个重复的名称？
Advanced filters is returning a single duplicate name at both the beginning and end of the created list?
我正在尝试将四个单独的名称列表合并为一个列表而不显示任何重复项。下面的代码使用高级过滤器首先从四个列表中过滤出唯一名称，然后将它们组合成一个名称列表。然后它再次对新创建的综合名称列表使用高级过滤器来仔细检查重复项，然后写入唯一名称的最终列表。
我的问题是最终名单显示了一个重复的名字，它同时出现在名单的开头和结尾。
Option Explicit
Sub CreateUniqueList()
Dim lastrow As Long
ActiveSheet.Range("d:d").Clear
ActiveSheet.Range("x:x").Clear
ActiveSheet.Range("g13:g36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("D2"), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("i13:i36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("k13:k36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("m13:m36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row
ActiveSheet.Range("d2:d" & lastrow).AdvancedFilter xlFilterCopy, , ActiveSheet.Range("x2"), True
ActiveSheet.Range("d:d").Clear
End Sub
我确定这是一个简单的错误，但我终究无法弄清楚。
从列中复制唯一值
AdvancedFilter 将复制 headers，因此如果第一行是 1，并且在下面某处找到 1，它将保持重复。一个想法是在最后一个 AdvancedFilter 操作之前复制从列 D 到 X 的范围，然后应用 RemoveDuplicates。- 但我选择了使用数据结构的更快解决方案，即将整个源范围写入数组，将源范围指定列中的唯一值写入字典，将字典中的值写入到另一个数组，最后，将数组中的值写入目标范围。此外，不需要辅助列。
Option Explicit
Sub CreateUniqueList()
' Source
Const sName As String = "Sheet1"
Const srgAddress As String = "G13:M36"
Dim sCols As Variant: sCols = Array(1, 3, 5, 7)
' Destination
Const dName As String = "Sheet1"
Const dfCellAddress As String = "X2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Return the values from the source range ('srg')
' in the 2D one-based source array ('sData').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range(srgAddress)
Dim sData As Variant: sData = srg.Value
' Return the unique values from the designated columns ('sCols')
' of the source array in a dictionary ('dict')
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim c As Long
For c = LBound(sCols) To UBound(sCols)
DictAddColumn dict, sData, sCols(c)
Next c
Erase sData
' Return the values from the dictionary
' in the 2D one-based one-column destination array ('dData').
Dim dData As Variant: dData = GetColumnDictKeys(dict)
Set dict = Nothing
Dim drCount As Long: drCount = UBound(dData, 1)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dfCellAddress)
' Write the result.
.Resize(drCount).Value = dData
' Clear below.
.Resize(dws.Rows.Count - .Row - drCount + 1) _
.Offset(drCount).ClearContents
End With
MsgBox "Unique list created.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds the unique values from a column ('sColumnIndex')
' of a 2D array ('sData') to an existing dictionary ('dDict').
' Remarks: Error values and blanks are excluded.
' Remarks: 'ByRef' indicates that the dictionary in the calling procedure
' will be modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddColumn( _
ByRef dDict As Object, _
ByVal sData As Variant, _
Optional ByVal sColumnIndex As Variant, _
Optional ByVal DoCount As Boolean = False)
Const ProcName As String = "DictAddColumn"
On Error GoTo ClearError
Dim sKey As Variant
Dim sr As Long
For sr = LBound(sData, 1) To UBound(sData, 1)
sKey = sData(sr, sColumnIndex)
If Not IsError(sKey) Then
If Len(CStr(sKey)) > 0 Then
If DoCount Then
dDict(sKey) = dDict(sKey) + 1
Else
dDict(sKey) = Empty
End If
End If
End If
Next sr
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the keys from a dictionary ('sDict')
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnDictKeys( _
ByVal sDict As Object) _
As Variant
Const ProcName As String = "GetColumnDictKeys"
On Error GoTo ClearError
Dim dData As Variant: ReDim dData(1 To sDict.Count, 1 To 1)
Dim sKey As Variant
Dim dr As Long
For Each sKey In sDict.Keys
dr = dr + 1
dData(dr, 1) = sKey
Next sKey
GetColumnDictKeys = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
编辑
- 此解决方案复制完整范围的值并应用
RemoveDuplicates。
Sub CreateUniqueListCopyByAssignment()
' without helper column
Const cCount As Long = 4
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range: Set srg = ws.Range("G13:G36")
Dim rCount As Long: rCount = srg.Rows.Count
Dim drg As Range: Set drg = ws.Range("X2").Resize(rCount)
Application.ScreenUpdating = False
ws.Range("X2:X" & ws.Rows.Count).Clear
Dim c As Long
For c = 0 To cCount - 1
drg.Offset(c * rCount).Value = srg.Offset(, c * 2).Value
Next c
drg.Resize(rCount * cCount).RemoveDuplicates 1, xlNo
Application.ScreenUpdating = True
End Sub
- 此解决方案与您的类似，但它适用于接近尾声的
RemoveDuplicates，在本 post 的顶部提到。我认为这些范围太小，无法收获 AdvancedFilter. 的力量
Sub CreateUniqueListQuickFix()
' with helper column
Application.ScreenUpdating = False
With ActiveSheet
Dim rCount As Long: rCount = .Rows.Count
Dim lr As Long
.Range("X2:X" & rCount).Clear
.Range("g13:g36").AdvancedFilter xlFilterCopy, , .Range("D2"), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("i13:i36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("k13:k36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("m13:m36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row
.Range("D2:D" & lr).RemoveDuplicates 1, xlNo
lr = Cells(rCount, "D").End(xlUp).Row
.Range("D2:D" & lr).Copy .Range("X2")
.Range("D2:D" & lr).Clear
End With
Application.ScreenUpdating = True
End Sub
我正在尝试将四个单独的名称列表合并为一个列表而不显示任何重复项。下面的代码使用高级过滤器首先从四个列表中过滤出唯一名称，然后将它们组合成一个名称列表。然后它再次对新创建的综合名称列表使用高级过滤器来仔细检查重复项，然后写入唯一名称的最终列表。
我的问题是最终名单显示了一个重复的名字，它同时出现在名单的开头和结尾。
Option Explicit
Sub CreateUniqueList()
Dim lastrow As Long
ActiveSheet.Range("d:d").Clear
ActiveSheet.Range("x:x").Clear
ActiveSheet.Range("g13:g36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("D2"), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("i13:i36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("k13:k36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("m13:m36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row
ActiveSheet.Range("d2:d" & lastrow).AdvancedFilter xlFilterCopy, , ActiveSheet.Range("x2"), True
ActiveSheet.Range("d:d").Clear
End Sub
我确定这是一个简单的错误，但我终究无法弄清楚。
从列中复制唯一值
AdvancedFilter将复制 headers，因此如果第一行是 1，并且在下面某处找到 1，它将保持重复。一个想法是在最后一个 AdvancedFilter 操作之前复制从列D到X的范围，然后应用RemoveDuplicates。- 但我选择了使用数据结构的更快解决方案，即将整个源范围写入数组，将源范围指定列中的唯一值写入字典，将字典中的值写入到另一个数组，最后，将数组中的值写入目标范围。此外，不需要辅助列。
Option Explicit
Sub CreateUniqueList()
' Source
Const sName As String = "Sheet1"
Const srgAddress As String = "G13:M36"
Dim sCols As Variant: sCols = Array(1, 3, 5, 7)
' Destination
Const dName As String = "Sheet1"
Const dfCellAddress As String = "X2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Return the values from the source range ('srg')
' in the 2D one-based source array ('sData').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range(srgAddress)
Dim sData As Variant: sData = srg.Value
' Return the unique values from the designated columns ('sCols')
' of the source array in a dictionary ('dict')
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim c As Long
For c = LBound(sCols) To UBound(sCols)
DictAddColumn dict, sData, sCols(c)
Next c
Erase sData
' Return the values from the dictionary
' in the 2D one-based one-column destination array ('dData').
Dim dData As Variant: dData = GetColumnDictKeys(dict)
Set dict = Nothing
Dim drCount As Long: drCount = UBound(dData, 1)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dfCellAddress)
' Write the result.
.Resize(drCount).Value = dData
' Clear below.
.Resize(dws.Rows.Count - .Row - drCount + 1) _
.Offset(drCount).ClearContents
End With
MsgBox "Unique list created.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds the unique values from a column ('sColumnIndex')
' of a 2D array ('sData') to an existing dictionary ('dDict').
' Remarks: Error values and blanks are excluded.
' Remarks: 'ByRef' indicates that the dictionary in the calling procedure
' will be modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddColumn( _
ByRef dDict As Object, _
ByVal sData As Variant, _
Optional ByVal sColumnIndex As Variant, _
Optional ByVal DoCount As Boolean = False)
Const ProcName As String = "DictAddColumn"
On Error GoTo ClearError
Dim sKey As Variant
Dim sr As Long
For sr = LBound(sData, 1) To UBound(sData, 1)
sKey = sData(sr, sColumnIndex)
If Not IsError(sKey) Then
If Len(CStr(sKey)) > 0 Then
If DoCount Then
dDict(sKey) = dDict(sKey) + 1
Else
dDict(sKey) = Empty
End If
End If
End If
Next sr
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the keys from a dictionary ('sDict')
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnDictKeys( _
ByVal sDict As Object) _
As Variant
Const ProcName As String = "GetColumnDictKeys"
On Error GoTo ClearError
Dim dData As Variant: ReDim dData(1 To sDict.Count, 1 To 1)
Dim sKey As Variant
Dim dr As Long
For Each sKey In sDict.Keys
dr = dr + 1
dData(dr, 1) = sKey
Next sKey
GetColumnDictKeys = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
编辑
- 此解决方案复制完整范围的值并应用
RemoveDuplicates。
Sub CreateUniqueListCopyByAssignment()
' without helper column
Const cCount As Long = 4
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range: Set srg = ws.Range("G13:G36")
Dim rCount As Long: rCount = srg.Rows.Count
Dim drg As Range: Set drg = ws.Range("X2").Resize(rCount)
Application.ScreenUpdating = False
ws.Range("X2:X" & ws.Rows.Count).Clear
Dim c As Long
For c = 0 To cCount - 1
drg.Offset(c * rCount).Value = srg.Offset(, c * 2).Value
Next c
drg.Resize(rCount * cCount).RemoveDuplicates 1, xlNo
Application.ScreenUpdating = True
End Sub
- 此解决方案与您的类似，但它适用于接近尾声的
RemoveDuplicates，在本 post 的顶部提到。我认为这些范围太小，无法收获AdvancedFilter. 的力量
Sub CreateUniqueListQuickFix()
' with helper column
Application.ScreenUpdating = False
With ActiveSheet
Dim rCount As Long: rCount = .Rows.Count
Dim lr As Long
.Range("X2:X" & rCount).Clear
.Range("g13:g36").AdvancedFilter xlFilterCopy, , .Range("D2"), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("i13:i36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("k13:k36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("m13:m36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row
.Range("D2:D" & lr).RemoveDuplicates 1, xlNo
lr = Cells(rCount, "D").End(xlUp).Row
.Range("D2:D" & lr).Copy .Range("X2")
.Range("D2:D" & lr).Clear
End With
Application.ScreenUpdating = True
End Sub