Скопируйте и вставьте каждое уникальное значение с одного листа на другой

Question

У меня может быть до 8 уникальных значений в столбце D. Я ищу код, который будет копировать и вставлять каждую строку с уникальным значением на новый лист.

Так что у меня может быть до 8 новых листов.

Не могли бы вы помочь мне создать код, который будет делать это?

Это то, что у меня есть до сих пор:

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

Дело в том, что этот макрос создает новые листы, в которых нет необходимости.Я только хочу сделать следующее.

Если вы найдете уникальное значение в столбце D (у которого будет точное имя, как у другого листа), найдите этот лист и вставьте туда всю строку.

Answer 1

Хорошо, я сделал обходной путь.Я создал список уникальных значений на отдельном листе.

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

Спасибо всем за помощь и ваше время!

Answer 2

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