Question

我有一个问题。我试图将所有唯一值（数字和字母数字）从动态工作表复制到另一个。我在一个论坛上找到了一个很棒的剧本，它可以很快地运行并且已经适应了问题是，它似乎过滤掉了所有的数值，对于我的生活，我看不出为什么！？！你能帮忙吗？

    Sub GetUniqueItems()
    Dim vData As Variant, n&, lLastRow&, sMsg$

    lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value)._
    Cells(Rows.Count, "H").End(xlUp).Row
    If lLastRow = 1 Then Exit Sub '//no data

    vData = Worksheets(Worksheets("Summary").Range("A1").Value)._
    Range("H2:H" & lLastRow)
    Dim oColl As New Collection
    On Error Resume Next
    For n = LBound(vData) To UBound(vData)
    oColl.Add vData(n, 1), vData(n, 1)
    Next 'n

    For n = 1 To oColl.Count
    sMsg = oColl(n)
    Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1)
    Next 'n

    End Sub

Answer 1

Collection项的键必须是字符串。所以改变这一行：

oColl.Add vData(n, 1), vData(n, 1)

到此：

oColl.Add vData(n, 1), CStr(vData(n, 1))

此外，虽然您需要On Error Resume Next所以代码将skip over尝试向集合中添加重复项，但您应该只将它用于该行。否则，您可能会在代码中屏蔽其他错误。（您的代码没有运行时错误的原因是因为On Error Resume Next除了执行绕过重复项的工作外，还使用数字Adds跳过任何Keys。< / p>

出于这个原因，我将该行移至oColl.Add之前，并在之后添加了On Error Goto 0：

这是完整的例程：

Sub GetUniqueItems()
Dim vData As Variant, n&, lLastRow&, sMsg$
Dim oColl As Collection

lLastRow = Worksheets(Worksheets("Summary").Range("A1").Value).Cells(Rows.Count, "H").End(xlUp).Row
If lLastRow = 1 Then Exit Sub

vData = Worksheets(Worksheets("Summary").Range("A1").Value).Range("H2:H" & lLastRow)
Set oColl = New Collection
For n = LBound(vData) To UBound(vData)
    On Error Resume Next
    oColl.Add vData(n, 1), CStr(vData(n, 1))
    On Error GoTo 0
Next n

For n = 1 To oColl.Count
    sMsg = oColl(n)
    Sheets("Summary").Cells(n + 3, 1).Value = Mid$(sMsg, 1)
Next n
End Sub

最后一件事：你想避免像Dim oColl As New Collection这样的陈述，而是像我一样在两个步骤中声明和设置它。因此，请参阅Chip Pearson page并向下滚动到“不使用自动实例化对象变量。”

Answer 2

我正在展示下面的代码，因为它可能对OP或其他人感兴趣，并且是从一列数据中获取唯一列表的有效方法。

在Excel 2007或更高版本中，我们可以复制该列并使用Remove Duplicates功能获取我们的唯一列表。

Sub CreateUniqueList()
    Dim lLastRow As Long
    Dim wsSum As Worksheet
    Dim rng As Range

    Set wsSum = Worksheets("Summary")
    lLastRow = wsSum.Cells(Rows.Count, "H").End(xlUp).Row
    If lLastRow = 1 Then Exit Sub

    wsSum.Range("H2:H" & lLastRow).Copy wsSum.Cells(4, 1)
    wsSum.Range(wsSum.Cells(4, 1), wsSum.Cells(4 + lLastRow - 2, 1)). _
        RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

唯一的缺点是我们首先必须复制整个列，但与大量数据的性能提升相比，这是次要的。

vba复制单元格值过滤掉数字数据

2 个答案: