sorting to other worksheets

[NatureGreen]

Hi all

Every week i get a new report with over 600 employees.
Each of them are asigned to a coach. (Column I)

I have to select them and make a new worksheet per coach.
So that every coach has a clear list.

How can i automate this so that i can put the report on sheet 1 and that it automatically makes a new sheet for every coach?

Idk how i can add a better example but it's something like this but with more columns.

So it's based on the column Coach and the amount of employees can shift alot.

Employer	type	company	Group	place	id location	unit	Adres	Coach	name	firstname	Work ID
JOBA	fulltime	Place A	dlfkjmsdfj	dlfjiel	108080	Zone B	Street	John	Person 1	Firstname 1	1563050580
JOBB	Parttime	Place B	dmfkd	dlfkjmsdfj	108080	Zone A	Lane	John	Person 2	Firstname 2	1562885584
JOBB	fulltime	Place D	fmdjfoe	dmfkd	15568	Zone D	Drive	Josy	Person 3	Firstname 3	1562907624
JOBA	Parttime	Place A	dfjldkjfl	fmdjfoe	43984	Zone C	Road	Jenny	Person 4	Firstname 4	1562989780

<colgroup><col style="mso-width-source:userset;mso-width-alt:3072;width:66pt" width="88"> <col style="mso-width-source:userset;mso-width-alt:2141;width:46pt" width="61"> <col style="mso-width-source:userset;mso-width-alt:3025;width:65pt" width="87"> <col style="mso-width-source:userset;mso-width-alt:2466;width:53pt" width="71"> <col style="mso-width-source:userset;mso-width-alt:2327;width:50pt" width="67"> <col style="mso-width-source:userset;mso-width-alt:3211;width:69pt" width="92"> <col style="mso-width-source:userset;mso-width-alt:2048;width:44pt" width="59"> <col style="mso-width-source:userset;mso-width-alt:2420;width:52pt" width="69"> <col style="mso-width-source:userset;mso-width-alt:2536;width:55pt" width="73"> <col style="mso-width-source:userset;mso-width-alt:2350;width:51pt" width="67"> <col style="mso-width-source:userset;mso-width-alt:3025;width:65pt" width="87"> <col style="mso-width-source:userset;mso-width-alt:2769;width:60pt" width="79"> </colgroup><tbody>
</tbody>

Thanks in advance.

 

[Scott T]

Try

Sub movetosheet()
Dim lr As Long
Dim lrc As Long
Dim ws As Worksheet
lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For x = lr To 2 Step -1
    
    'test if sheet already exists
    Dim worksh As Integer
    Dim worksheetexists As Boolean
    worksh = Application.Sheets.Count
    worksheetexists = False
    For A = 1 To worksh
        If Worksheets(A).Name = Sheets("Sheet1").Cells(x, "I") Then
            worksheetexists = True
            Exit For
        End If
    Next A
    
    If worksheetexists = True Then
        newname = Sheets("Sheet1").Cells(x, "I")
        lrc = Sheets(newname).Cells(Rows.Count, 1).End(xlUp).Row + 1
        Sheets("Sheet1").Rows(x).Cut Sheets(newname).Cells(lrc, 1)
    Else
        newname = Sheets("Sheet1").Cells(x, "I")
        Sheets.Add(After:=Sheets(Sheets.Count)).Name = newname
        Sheets("Sheet1").Rows(1).Copy Sheets(newname).Range("A1")
        lrc = Sheets(newname).Cells(Rows.Count, 1).End(xlUp).Row + 1
        Sheets("Sheet1").Rows(x).Cut Sheets(newname).Cells(lrc, 1)
    
    End If
        
Next x
 
End Sub

 

[NatureGreen]

it works for 1 line. (the last one) But then it stops and gives an 1004 error.
So i got 1 extra sheet with the titles + 1 row with data.

Is it also possible to copy them to those sheets instead of pasting them to the new sheet? So i can keep the first sheets as a complete list.

 

[Scott T]

What line is highlighted when you debug?

You can change .cut to .copy to copy them to the new sheet, but if you run the code again it will copy the lines over again.

 

[NatureGreen]

The blue line is the one that gives an error. After adding 1 line to a new sheet.
Probably cause the sheet name doesn't have the name "Sheet1" anymore but the name of the Coach.


If worksheetexists = True Then
newname = Sheets("Sheet1").Cells(x, "J")
lrc = Sheets(newname).Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("Sheet1").Rows(x).Cut Sheets(newname).Cells(lrc, 1)
Else
newname = Sheets("Overzicht_Alle").Cells(x, "J")
Sheets.Add(After:=Sheets(Sheets.Count)).Name = newname
Sheets("Overzicht_Alle").Rows(1).Copy Sheets(newname).Range("A1")
lrc = Sheets(newname).Cells(Rows.Count, 1).End(xlUp).Row + 1
Sheets("Overzicht_Alle").Rows(x).Cut Sheets(newname).Cells(lrc, 1)

End If

 

[Scott T]

The code does not rename any existing sheets only create new ones. What is in that cell? If the cell has a value that has characters that can not be used in a sheet name you will get that error.

 

[NatureGreen]

Those cells only contain the names of the coaches without any special symbols.