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.

Welcome to Stack Overflow. Please note that because this is no free code writing service it is necessary to show either what you have tried so far and where you got stuck or errors (by showing your code) or at least to show what you have researched and the effort you made. Otherwise it is just asking us to do all the work for you. Reading [ask] might help you to improve your question. Your question is a way too generic to give an answer, also have a look at [mcve]. — Pᴇʜ, Nov 26 '18 at 08:16
I'm still confused what your goal is. First you say *"am looking for a code that will copy & paste each row with unique value **to a new sheet.**"* But in the end you say *"this macro is creating new sheets, which is not necessary."*. Please describe more detailed what your macro actually should do. Be more concrete. The actual issue is still unclear. — Pᴇʜ, Nov 26 '18 at 08:47
Sorry! I was not clear, I agree. What I want to be done is: In column K can be stored 8 different values. For example cell K10 can be "Marek", cell K11 can have value "Peh", K12 will have "Marek" again, etc. I already have different sheets created in the same workbook - "Marek", "Peh", etc. What I want to do is following. If macro finds "Marek" in column K, whole row will be copied and pasted to sheet "Marek" in cell "A10". If macro finds again "Marek" in column K in next row in my mastersheet, whole row will be pasted in cell "A11" in sheet "Marek". Thank You! — Marek Re, Nov 26 '18 at 10:38

Michal Rosa · Answer 1 · 2018-11-26T11:17:18.677

0

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

edited Nov 26 '18 at 11:17

answered Nov 26 '18 at 09:08

Michal Rosa

2,459
2
15
28

Hey Michal, thank you for help! However, could you provide some comments to that? It is not working, I get the error msg "Run-time error "13" / Type mismatch' on row lng= .Range("D" & Rows.Count).End(xlUp) – Marek Re Nov 26 '18 at 10:58
@MarekRe try `lng = .Range("D" & .Rows.Count).End(xlUp).Row` instead, he just forgot the `.Row` in the end. – Pᴇʜ Nov 26 '18 at 11:02
@MarekRe - try now, fixed the typo. – Michal Rosa Nov 26 '18 at 11:17

score 0 · Answer 2 · edited Nov 27 '18 at 07:39

0

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!

edited Nov 27 '18 at 07:39

Pᴇʜ

56,719
10
49
73

answered Nov 26 '18 at 11:18

Marek Re

27
7

1

I highly recommend to read and apply [How to avoid using Select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba). Also I recommend to activate `Option Explicit`: In the VBA editor go to *Tools* › *Options* › *[Require Variable Declaration](https://www.excel-easy.com/vba/examples/option-explicit.html)*. Both make your code more stable, faster and secure and lead into less errors. – Pᴇʜ Nov 27 '18 at 07:40

Copy & paste each unique value from one sheet to another

2 Answers2