Split my data into separate worksheets

Try this:

Option Explicit

Sub CreateVPSheets()
Dim LR As Long, LC As Long, i As Long
Dim wsData As Worksheet
Application.ScreenUpdating = False

Set wsData = Sheets("Sheet1")

With wsData
    .Rows(1).Insert xlShiftDown
    LR = .Range("C" & .Rows.Count).End(xlUp).Row
    LC = .Cells(LR, .Columns.Count).End(xlToLeft).Column + 10
    
    .Cells(1, LC) = "key"
    .Range(.Cells(2, LC), .Cells(LR, LC)).FormulaR1C1 = "=IF(RC1=""VP"",N(R[-1]C)+1,N(R[-1]C))"
    
    For i = 1 To Application.WorksheetFunction.Max(Columns(LC))
        .Columns(LC).AutoFilter Field:=1, Criteria1:=i
        Worksheets.Add After:=Sheets(Sheets.Count)
        .Range("A2", .Cells(LR, LC - 1)).SpecialCells(xlCellTypeVisible).Copy Range("A1")
        ActiveSheet.Name = Range("A2")
        Range("A1").Select
    Next i
    
    .AutoFilterMode = False
    .Columns(LC).ClearContents
    .Rows(1).Delete xlShiftUp
    .Activate
End With

Application.ScreenUpdating = True
End Sub