根据列中的值将行剪切到新工作表

Question

I have this list of products, and i want to:

1. Create new sheets based on the values on column C, if there's already a sheet with the same name as the cell value don't create a new sheet. (like "Abstract" in my example that already been created for row 2 and doesn't need to created again for row 3)

2. Cut the entire row to the matching sheet.

3. Make sure the first row is copied to all sheets.

This is a before picture

After Pic #1: new sheets created, nothing left on first sheet except the 1st row

After Pic #2: the sheet contains 2 products because there were 2 "Abstract" in column C

After Pic #3: the sheet contain 1 product because there was 1 "Plain" in column C

After Pic #4: the sheet contain 1 product because there was 1 "Shiny" in column C

Answer 1

This will get the job done.

• I Named the first sheet to "Worksheet".
• The code is dynamic, so you need to input 2 values by yourself:

Which range/names that should create the new worksheets:

Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list 

and how many columns you want to copy to the new sheets (it makes it more dynamic than take the whole row)

lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet

VBA Code:

Sub AddNewSheetFromRange2()
Dim c As Range
Dim ws As Worksheet
Dim myrange As Range
Dim lastcol As Integer
Dim lrow As Integer
Dim lrow_newsheet As Integer
Dim i As Integer

Set myrange = ThisWorkbook.Sheets("Worksheet").Range("C2:C5") 'Set range that should create the new worksheet list
lastcol = Cells(1, "C").Column 'Set how many column that should be copied to new worksheet

lrow = Cells(Rows.Count, 3).End(xlUp).Row 'find last row for range that should create the new worksheet list

i = 1 'Set first index loop to 1

For Each c In myrange.Cells
i = i + 1 'Create index for each loop, used to know which row that should be copied
    'Debug.Print c 'Print which Sheet Name that will be examine
    Set ws = Nothing
    On Error Resume Next
    Set ws = Worksheets(c.Value)
    On Error GoTo 0
        If ws Is Nothing Then

        With ThisWorkbook
            Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count)) 'Add new sheet after (not before)
            ws.Name = c.Value 'Rename the new sheet
        End With


        Dim WorksheetSheet As Worksheet 'Declare variable for Main worksheet
        Set WorksheetSheet = ActiveWorkbook.Worksheets("Worksheet") 'Name the Main sheet
        Dim NewSheet As Worksheet 'Declare variable for new worksheet
        Set NewSheet = ActiveWorkbook.Worksheets(ws.Name) 'Make all new worksheets dynamic by taking name from range

        'Copy Headers from Main sheet to New Worksheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(1, 1), Cells(1, 3)).Copy
        Worksheets(ws.Name).Activate
        ThisWorkbook.Worksheets(ws.Name).Range(Cells(1, 1), Cells(1, 3)).PasteSpecial

        'Copy row from Main sheet to New Worksheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
        Worksheets(ws.Name).Activate
        lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
        ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial

        'Clear row in Main sheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear

        Else

        'If worksheet already exists, then
        'Copy row from Main sheet to existing worksheet with exactly the same name
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Copy
        Worksheets(ws.Name).Activate
        lrow_newsheet = Cells(Rows.Count, 3).End(xlUp).Row + 1
        ThisWorkbook.Worksheets(ws.Name).Range(Cells(lrow_newsheet, 1), Cells(lrow_newsheet, lastcol)).PasteSpecial

        'Clear row in Main sheet
        Worksheets("Worksheet").Activate
        ThisWorkbook.Worksheets("Worksheet").Range(Cells(i, 1), Cells(i, lastcol)).Clear

        End If
Next c
End Sub

Visualizing the code in excel you will have to start with this:

and the final output will be this (the four rows into individual worksheets, if the name already exists, it will add to the already existing worksheet)