Unique list from a matrix to a single column

Question

I needed to collect a unique list of text from a matrix, ("J19:BU500" in my case which contains duplicates) and paste it in a column (column DZ in my case) in the same sheet.

I need to loop this for multiple sheets in the same workbook. I'm new to VBA and got this code from internet and customized a bit to my requirement. But I have two problems with the code:

1. When the matrix is empty in say sheet 5, the code runs fine upto sheet 4 and throws a runtime error at sheet5 and stops without looping further to next sheets.

2. Also, I actually wanted the unique list to start at Cell "DZ10". If I do that, the number of unique list reduces by 10. For say there are 25 uniques, only 15 gets pasted starting from cell "DZ10" whereas all 25 gets pasted from cell "DZ1".

Code:

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

Any help is highly appreciated. Thankyou

Answer 1

1. You need to select the correct amount of cells to fill in all data from an array. Like Range("DZ10").Resize(RowSize:=colUniques.Count)
2. That error probably means that colUniques is nothing and therefore has no .Count. So test if it is Nothing before you use it.

You will end up with something like below:

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