need vba to split sheet into multiple sheets

Hi there thuff,

now the code below is pretty crude, cause I want to go to sleep
It assumes the following about the workbook you're going to run it on: There is only 1 sheet with data - and that one is called "full report"
Make sure that's true

It will mess up your "full report" page, but I really didn't have time to fix it so all stays fine and looks wonderful and stuff.
At least this code will do what you're looking for (I think) - you can work from there to get it nicer as you want.
I will NOT be able to big updates on this anymore, so if you need radical changes, someone else will have to do it - small changes, I can do.

Please remember to click the * below left if this helps

Sub test()
Dim lr&, cell As Range, i&, x&, y&, a$, b$, c$, d$, e$, f$, g$, h$, ws As Worksheet

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error GoTo earlyexit

If ActiveSheet.Name <> "Full Report" Then Exit Sub
a = ActiveSheet.Range("A2").Value
b = ActiveSheet.Range("B2").Value
c = ActiveSheet.Range("C2").Value
d = ActiveSheet.Range("D2").Value
e = ActiveSheet.Range("E2").Value
f = ActiveSheet.Range("F2").Value
g = ActiveSheet.Range("G2").Value
h = ActiveSheet.Range("H2").Value

lr = Cells(Rows.Count, 1).End(xlUp).Row

Columns(1).Insert
Range("A1").FormulaR1C1 = "=IFERROR(RIGHT(RC[1], LEN(RC[1])-3),"""")"
Range("A1").AutoFill Destination:=Range("A1:A" & lr), Type:=xlFillDefault
Columns(1).Copy
Columns(1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
Worksheets("Full Report").Sort.SortFields.Clear
Worksheets("Full Report").Sort.SortFields.Add Key:=Range("A3:A" & lr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With Worksheets("Full Report").Sort
        .SetRange Range("A2:H" & lr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
End With
For i = lr To 1 Step -1
If Cells(i, 1).Value = "" Or Len(Cells(i, 1)) < 4 Or IsNumeric(Mid(Cells(i, 1), 4, 1)) = False Then Cells(i, 1).EntireRow.Delete
Next i
Columns(1).Delete

Rows(1).Insert
Range("A1").Value = "iloveexcelforum.com"

lr = Cells(Rows.Count, 1).End(xlUp).Row

For Each cell In Range("A2:A" & lr)
i = InStr(cell.Value, "-")
If Mid(cell.Value, i, Len(cell.Value) - i) <> Mid(cell.Offset(-1, 0).Value, i, Len(cell.Offset(-1, 0).Value) - i) Then
If cell.Row = 2 Then GoTo nc
On Error Resume Next
Set ws = Worksheets(Mid(cell.Offset(-1, 0).Value, i + 1, Len(cell.Offset(-1, 0).Value) - i))
On Error GoTo earlyexit

If ws Is Nothing Then Worksheets.Add(After:=ActiveSheet).Name = Mid(cell.Offset(-1, 0).Value, i + 1, Len(cell.Offset(-1, 0).Value) - i)
Range("A" & x & ":A" & cell.Row - 1).EntireRow.Copy
Worksheets(Mid(cell.Offset(-1, 0).Value, i + 1, Len(cell.Offset(-1, 0).Value) - i)).Range("A1").PasteSpecial
Application.CutCopyMode = False
nc:
x = cell.Row
End If
Next cell

For i = 1 To Worksheets.Count
If Worksheets(i).Range("A1").Value = "" Then GoTo nxi
If Worksheets(i).Name <> "Full Report" Then
Worksheets(i).Rows(1).Insert
Worksheets(i).Rows(1).Insert
Worksheets(i).Rows(1).Insert
Worksheets(i).Range("A1").Value = Worksheets(i).Name
Worksheets(i).Range("A2").Value = a
Worksheets(i).Range("B2").Value = b
Worksheets(i).Range("C2").Value = c
Worksheets(i).Range("D2").Value = d
Worksheets(i).Range("E2").Value = e
Worksheets(i).Range("F2").Value = f
Worksheets(i).Range("G2").Value = g
Worksheets(i).Range("H2").Value = h
Worksheets(i).Range("A3").Value = "CUP " & Left(Worksheets(i).Range("A4"), InStr(Worksheets(i).Range("A4"), "-") - 1)
Worksheets(i).Rows("1:3").Font.Bold = True

lr = Worksheets(i).Cells(Rows.Count, 1).End(xlUp).Row
y = 4
x = 5
Do Until x = lr + 60
If Left(Worksheets(i).Cells(x, 1), InStr(Worksheets(i).Cells(x, 1), "-")) <> Left(Worksheets(i).Cells(x - 1, 1), InStr(Worksheets(i).Cells(x - 1, 1), "-")) Then
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Rows(x).Insert
Worksheets(i).Cells(x + 1, 1).Value = "Cup " & Left(Worksheets(i).Cells(x - 1, 1), InStr(Worksheets(i).Cells(x - 1, 1), "-")) & " Total :"
Worksheets(i).Cells(x + 1, 5).FormulaR1C1 = "=SUM(R[-" & x - y + 1 & "]C:R[-2]C)"
Worksheets(i).Cells(x + 1, 6).FormulaR1C1 = "=SUM(R[-" & x - y + 1 & "]C:R[-2]C)"
Worksheets(i).Cells(x + 1, 7).FormulaR1C1 = "=SUM(R[-" & x - y + 1 & "]C:R[-2]C)"
Worksheets(i).Cells(x + 3, 1).Value = "Cup " & Left(Worksheets(i).Cells(x + 4, 1), InStr(Worksheets(i).Cells(x + 4, 1), "-"))
Worksheets(i).Rows(x & ":" & x + 3).Font.Bold = True
x = x + 4
y = x
End If
x = x + 1
Loop
End If
nxi:
Next i

Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub

earlyexit:
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Err.Description

End Sub

Please remember to click the * below left if this helps

On your sample it worked fine.
Please make sure of the following :

- Put the code in the WORKSHEET CODE AREA of worksheet with the name 'Full Report'
- Run the code while the 'Full Report' sheet is the active sheet

Please try again - make sure you don't put the code in a module, but in the worksheet code area of "Full Report"
Thanks

Based on your last post in this thread, its apparent that you are satisfied with the solution(s) you've received and have solved your question, but you haven't marked your thread as "SOLVED". I will do it for you this time.

In future, to mark your thread as Solved, you can do the following -
Select Thread Tools-> Mark thread as Solved.

Incase your issue is not solved, you can undo it as follows -
Select Thread Tools-> Mark thread as Unsolved.

Also, since you are relatively new to the forum, i would like to inform you that you can thank those who have helped you by clicking the small star icon located in the lower left corner of the post which helped you. This adds to the reputation of the person who has taken the time to help you.