VBA stop using temporary ranges

Question

I'm new to vba so I need some help making my macro more efficient. It does return the desired outcome however I know there must be a much quicker way to do so I just do not have the vba experience to know how.

I have a column which contains names of people assigned to a project. Some are only one name, and others may be multiple, for example:

At the moment, my code goes through this column, separates the names by comma, and enters them individually into a new range like so:

I then use a collection for the unique names and enter them in the final desired list. The names must show up three times, blank row, next three rows are the next name, so on.It should look like this in the end:

Currently my code is the following

Sub FindUniques()
Dim Ws As Worksheet, Ns As Worksheet
Dim SubString() As String, m As Integer, k As Long, NameCount As Integer
Dim allNames As New Collection, tempRng As Range


Set Ns = Worksheets("Sheet2")
Set Ws = Worksheets("Sheet1")


'Loops through the Assigned To column, separates and finds unique names
On Error Resume Next
For i = 1 To Ws.Range("A:A").End(xlDown).Row - Range("Assigned_to").Row
    SubString = Split(Range("Assigned_to").Offset(i), ", ")
    For j = 0 To UBound(SubString)
        allNames.Add (allNames.count), SubString(j)
    Next j
Next i
On Error GoTo 0

NameCount = allNames.count

    For k = 1 To NameCount
        For m = 1 To 4
            Ns.Cells((k - 1) * 4 + m + 7, 2) = allNames.Key(k)
        Next
        Range("Names").Offset((k - 1) * 4).ClearContents
    Next

End Sub

It works, however there must be some way that is more efficient than entering the names into a new range and then deleting the range. How can I use a collection or an array or something of the sort to make it quicker? Any ideas would be really appreciated

edit: I have now updated the code and it is using an collection, taking values from the substring. This enters the item (0, 1, 2, ...) in the cells instead of the keys (keys here are the names). How do I get it to return the key instead of the item number?

Answer 1

The slowest part of VBA are worksheet interactions so we should attempt to minimize that as much as possible.

Sub FindUniques()

    Dim ws As Worksheet, ns As Worksheet
    Dim splitStr() As String, nameStr As Variant
    Dim dict As New Dictionary
    Dim lastRow As Long, i As Long
    
    Set ns = Worksheets("Sheet2")
    Set ws = Worksheets("Sheet1")
    
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    'Loops through the Assigned To column, separates and finds unique names
    For i = 2 To lastRow
        splitStr = Split(CStr(ws.Cells(i, 1).Value), ", ")
        For Each nameStr In splitStr
            If Not dict.Exists(nameStr ) Then dict.Add nameStr , 0
        Next
    Next i
    
    i = 2
    For Each nameStr In dict.Keys
        ns.Cells(i, 1).Resize(3).Value = nameStr 
        
        i = i + 4
    Next

End Sub

Edited With @Toddleson & @BigBen 's suggestions
Good Luck!