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.

[TABLE="class: grid, width: 500"]
<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>[TR]
[TD="width: 88"]Employer
[/TD]
[TD="width: 61"]type[/TD]
[TD="width: 87"]company[/TD]
[TD="width: 71"]Group[/TD]
[TD="width: 67"]place[/TD]
[TD="width: 92"]id location[/TD]
[TD="width: 59"]unit[/TD]
[TD="width: 69"]Adres[/TD]
[TD="width: 73, align: center"]Coach
[/TD]
[TD="width: 67"]name[/TD]
[TD="width: 87"]firstname[/TD]
[TD="width: 79"]Work ID[/TD]
[/TR]
[TR]
[TD]JOBA
[/TD]
[TD]fulltime[/TD]
[TD]Place A[/TD]
[TD]dlfkjmsdfj[/TD]
[TD]dlfjiel[/TD]
[TD]108080[/TD]
[TD]Zone B[/TD]
[TD]Street[/TD]
[TD="align: center"]John
[/TD]
[TD]Person 1[/TD]
[TD]Firstname 1[/TD]
[TD="align: right"]1563050580[/TD]
[/TR]
[TR]
[TD]JOBB
[/TD]
[TD]Parttime
[/TD]
[TD]Place B
[/TD]
[TD]dmfkd[/TD]
[TD]dlfkjmsdfj
[/TD]
[TD]108080[/TD]
[TD]Zone A[/TD]
[TD]Lane[/TD]
[TD="align: center"]John[/TD]
[TD]Person 2[/TD]
[TD]Firstname 2[/TD]
[TD="align: right"]1562885584[/TD]
[/TR]
[TR]
[TD]JOBB
[/TD]
[TD]fulltime[/TD]
[TD]Place D
[/TD]
[TD]fmdjfoe
[/TD]
[TD]dmfkd
[/TD]
[TD]15568[/TD]
[TD]Zone D[/TD]
[TD]Drive[/TD]
[TD="align: center"]Josy[/TD]
[TD]Person 3[/TD]
[TD]Firstname 3[/TD]
[TD="align: right"]1562907624[/TD]
[/TR]
[TR]
[TD]JOBA
[/TD]
[TD]Parttime
[/TD]
[TD]Place A[/TD]
[TD]dfjldkjfl[/TD]
[TD]fmdjfoe[/TD]
[TD]43984[/TD]
[TD]Zone C[/TD]
[TD]Road[/TD]
[TD="align: center"]Jenny[/TD]
[TD]Person 4[/TD]
[TD]Firstname 4[/TD]
[TD="align: right"]1562989780[/TD]
[/TR]
</tbody>[/TABLE]


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.