无法从范围中删除重复项

Question

我有一个excel表，其中包含两个我感兴趣的列。我要做的是使用特定条件过滤第一列，然后将另一列中的可见值复制到范围对象中。之后我需要删除重复项。问题是我收到了错误。这是代码。有很多重复。请告诉我错误或建议更好的方法来完成我想要做的任务。

Sub Begin()

Dim tbl As ListObject
Set tbl = Worksheets("Sheet1").ListObjects("Table1")

WorkSheet.AutoFilterMode = False
tbl.Range.AutoFilter Field:=8, Criteria1:="DUKESTREET_II-2"

Dim rng1 As Range
Set rng1 =  tbl.ListColumns("TGT CELL NAME").DataBodyRange.SpecialCells(xlCellTypeVisible)
MsgBox rng1.Count
rng1.RemoveDuplicates Columns:=1, Header:=xlNo
MsgBox rng1.Count

End Sub

Answer 1

你有一个良好的开端，但不幸的是，@ siddharth-rout指出.RemoveDuplicates将无法在非连续范围内工作。

在这种情况下，要从＆＃34; TGT CELL NAME＆＃34;收集所有唯一的单元格值。列，您可以使用collection（MSDN链接）：

Sub Begin()

Dim tbl As ListObject
Dim rng1 As Range, RngIdx As Range
Dim MySheet As Worksheet
Dim UniqueTGTCells As Collection

Set MySheet = ThisWorkbook.Worksheets("Sheet1")
Set tbl = MySheet.ListObjects("Table1")

'only turn off auto filter mode if it's already set to true
If MySheet.AutoFilterMode = True Then
    MySheet.AutoFilterMode = False
End If

tbl.Range.AutoFilter Field:=8, Criteria1:="DUKESTREET_II-2"

Set rng1 = tbl.ListColumns("TGT CELL NAME").DataBodyRange.SpecialCells(xlCellTypeVisible)
MsgBox rng1.Count

'populate the collection object
Set UniqueTGTCells = New Collection
For Each RngIdx In rng1
    On Error Resume Next
    UniqueTGTCells.Add LCase(CStr(RngIdx.Value)), LCase(CStr(RngIdx.Value))
    On Error GoTo 0
Next RngIdx

'message the size of the collection
MsgBox UniqueTGTCells.Count

End Sub

以下是我们的消息框：

Answer 2

我自己解决下面这个老帖子，以防任何人再次与之斗争。
请注意，我将我的工作代码转换为已发布的代码而未进行测试，但我想这个想法很简单，无论如何都可以应用。

Sub Begin()


Dim tbl As ListObject
Set tbl = Worksheets("Sheet1").ListObjects("Table1")

WorkSheet.AutoFilterMode = False
tbl.Range.AutoFilter Field:=8, Criteria1:="DUKESTREET_II-2"
' Sort to make sure filtered view will be contiguous
tbl.range.sort Key1:=tbl.range.cells(1,8), Order1:=xlAscending, Header:=xlYes

Dim rng1 As Range
Set rng1 =  tbl.ListColumns("TGT CELL NAME").DataBodyRange.SpecialCells(xlCellTypeVisible)
MsgBox rng1.Count
' Using Areas(1) does the trick (there is only 1 area - no gaps - thanks to sorting)
rng1.Areas(1).RemoveDuplicates Columns:=1, Header:=xlNo
MsgBox rng1.Count

End Sub