Question

我需要从矩阵中收集一个唯一的文本列表，（＆＃34; J19：BU500＆＃34;在我的情况下包含重复项）并将其粘贴到一列（我的情况下为DZ列）中片。

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

当表5中的矩阵为空时，代码运行正常到表4并在sheet5处抛出运行时错误并停止而不进一步循环到下一页。
另外，我实际上想要从Cell＆＃34; DZ10＆＃34;开始的唯一列表。如果我这样做，唯一列表的数量减少10个。例如，有25个唯一身份，只有15个从小区开始粘贴＆＃34; DZ10＆＃34;而所有25个都是从小区＆＃34; DZ1＆＃34;。

代码：

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

从矩阵到单列的唯一列表

1 个答案: