vba - 从矩阵到单列的唯一列表

Question

我需要从矩阵中收集唯一的文本列表(在我的情况下为“J19:BU500”，其中包含重复项)并将其粘贴到同一张表的列(在我的情况下为 DZ 列)中。

我需要为同一个工作簿中的多张工作表循环。我是 VBA 的新手，从互联网上获得了这段代码，并根据我的要求进行了一些定制。但是我的代码有两个问题:

当表 5 中的矩阵为空时，代码在表 4 上运行良好，并在表 5 处引发运行时错误，并停止而不进一步循环到下一张表。

此外，我实际上希望唯一列表从单元格“DZ10”开始。如果我这样做，唯一列表的数量会减少 10。例如，有 25 个唯一列表，只有 15 个从单元格“DZ10”开始粘贴，而所有 25 个都从单元格“DZ1”粘贴。

代码:

Public Function CollectUniques(rng As Range) As Collection

    Dim varArray As Variant, var As Variant
    Dim col As Collection

    If rng Is Nothing Or WorksheetFunction.CountA(rng) = 0 Then
        Set CollectUniques = col
        Exit Function
    End If

    If rng.Count = 1 Then 
        Set col = New Collection
        col.Add Item:=CStr(rng.Value), Key:=CStr(rng.Value)
    Else 

        varArray = rng.Value
        Set col = New Collection

        On Error Resume Next

            For Each var In varArray
                If CStr(var) <> vbNullString Then
                    col.Add Item:=CStr(var), Key:=CStr(var)
                End If
            Next var

        On Error GoTo 0
    End If

    Set CollectUniques = col

End Function

Public Sub WriteUniquesToNewSheet()

    Dim wksUniques As Worksheet
    Dim rngUniques As Range, rngTarget As Range
    Dim strPrompt As String
    Dim varUniques As Variant
    Dim lngIdx As Long
    Dim colUniques As Collection
    Dim WS_Count As Integer
    Dim I As Integer
    Set colUniques = New Collection

    WS_Count = ActiveWorkbook.Worksheets.Count
    For I = 3 To WS_Count
     Sheets(I).Activate

    Set rngTarget = Range("J19:BU500")
    On Error GoTo 0
    If rngTarget Is Nothing Then Exit Sub '<~ in case the user clicks Cancel

    Set colUniques = CollectUniques(rngTarget)

    ReDim varUniques(colUniques.Count, 1)
    For lngIdx = 1 To colUniques.Count
        varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
    Next lngIdx

    Set rngUniques = Range("DZ1:DZ" & colUniques.Count)
    rngUniques = varUniques

    Next I

    MsgBox "Finished!"

End Sub

非常感谢任何帮助。谢谢

Answer 1

您需要选择正确数量的单元格来填充数组中的所有数据。点赞Range("DZ10").Resize(RowSize:=colUniques.Count)

该错误可能意味着 colUniques什么都不是，因此没有 .Count .所以测试是不是Nothing在你使用它之前。

你最终会得到如下的结果:

Public Sub WriteUniquesToNewSheet()
    Dim wksUniques As Worksheet
    Dim rngUniques As Range, rngTarget As Range
    Dim strPrompt As String
    Dim varUniques As Variant
    Dim lngIdx As Long
    Dim colUniques As Collection
    Dim WS_Count As Integer
    Dim I As Integer
    Set colUniques = New Collection

    WS_Count = ActiveWorkbook.Worksheets.Count

    For I = 3 To WS_Count
        Sheets(I).Activate

        Set rngTarget = Range("J19:BU500")
        'On Error GoTo 0 'this is pretty useless without On Error Resume Next
        If rngTarget Is Nothing Then Exit Sub 'this is never nothing if you hardcode the range 2 lines above (therefore this test is useless)

        Set colUniques = CollectUniques(rngTarget)

        If Not colUniques Is Nothing Then
            ReDim varUniques(colUniques.Count, 1)
            For lngIdx = 1 To colUniques.Count
                varUniques(lngIdx - 1, 0) = CStr(colUniques(lngIdx))
            Next lngIdx

            Set rngUniques = Range("DZ10").Resize(RowSize:=colUniques.Count)
            rngUniques = varUniques
        End If
    Next I

    MsgBox "Finished!"
End Sub