Copy & paste each unique value from one sheet to another

Question

I may have up to 8 unique values in column D. I am looking for a code that will copy & paste each row with unique value to a new sheet.

So I may have up to 8 new sheets.

Could you help me to build the code that will do that?

This is what I have so far:

Option Explicit
Sub AddInstructorSheets()
    Dim LastRow As Long, r As Long, iName As String
    Dim wb As Workbook, ws As Worksheet, ts As Worksheet, nws As Worksheet
    Dim i As Integer
    Dim m As Integer

    'set objects
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    Set ts = Sheets("Master")

    'set last row of instructor names
    LastRow = ws.Cells(ws.Rows.Count, "K").End(xlUp).Row

    'add instructor sheets
    On Error GoTo err
    Application.ScreenUpdating = False
    For r = 17 To LastRow 'assumes there is a header
        iName = ws.Cells(r, 4).Value

        With wb 'add new sheet
            ts.Copy After:=.Sheets(.Sheets.Count) 'add template
            Set nws = .Sheets(.Sheets.Count)
            nws.Name = iName
            Worksheets(iName).Rows("17:22").Delete
            Worksheets("Master").Activate
            Range(Cells(r, 2), Cells(r, 16)).Select
            Selection.Copy
            m = Worksheets(iName).Range("A15").End(xlDown).Row
            Worksheets(iName).Cells(m + 1, 1).PasteSpecial Paste:=xlPasteValues
            Application.CutCopyMode = False
        End With
    Next r

err:
    ws.Activate
    Application.ScreenUpdating = True  
End Sub

The thing is that this macro is creating new sheets, which is not necessary. I only want to make following.

If you find a unique value in column D (which will have exact name as other sheet), find this sheet and paste whole row in there.

Answer 1

Sub CopyFromColumnD()


    Dim key As Variant
    Dim obj As Object
    Dim i As Integer, lng As Long, j As Long
    Dim sht As Worksheet, mainsht As Worksheet


    Set obj = CreateObject("System.Collections.ArrayList")
    Set mainsht = ActiveSheet

    With mainsht
        lng = .Range("D" & .Rows.Count).End(xlUp).Row
        With .Range("D1", .Range("D" & lng))
            For Each key In .Value
                If Not obj.Contains(key) Then obj.Add key
            Next
        End With
    End With

    For i = 0 To obj.Count - 1
        Set sht = Sheets.Add(After:=Sheets(Sheets.Count))
        sht.Name = obj(i)

        For j = 1 To lng
            If mainsht.Cells(j, 4).Value = obj(i) Then
                    mainsht.Rows(j).EntireRow.Copy Destination:=Range("A1")
                Exit For
            End If
        Next
    Next

 End Sub

Answer 2

Ok, I did the workaround. I have created a list of unique values in a separate sheet.

Sub copypaste() 
    Dim i As Integer 
    Dim j As Integer

    LastRow = Worksheets("Master").Range("D17").End(xlDown).Row

    For i = 17 To LastRow
        For j = 2 To 10
            Workstream = Worksheets("Database").Cells(j, 5).Value

            Worksheets("Master").Activate
            If Cells(i, 4) = Worksheets("Database").Cells(j, 5).Value Then
                Range(Cells(i, 2), Cells(i, 16)).Select
                Selection.Copy
                Worksheets(Workstream).Cells(1, 1).PasteSpecial Paste:=xlPasteValues
            Else

            End If    
        Next j 
    Next i
End Sub

Thank you everyone for help and your time!