Creating new tabs using relevant info from Sheet1

Question

I have a code that takes the data from Sheet1 (an export from a program) and creates a Rollup that combines all the same part numbers and adds the quantities together. I want to now create an additional function that separates the projects with uniques identifiers in the PRTCOL and puts each on its own tab with accompanying info like all the parts that are underneath that project. There is a level identifier where "2" is the items needed to separate.

The issue that I am runnining into is that in some of the level 2 projects there will be an additional project that needs to be complete which is idenitied as level 3 and the parts needed for those are identified as level 4. So ideally, it would break the level 2 projects down and then further break down the level 3 projects. Now the tricky part is that I only want to breakdown the parts that begin with 1TDxxx as that symbolizes a project to complete that has additional parts inside rather than just any value.

Sub ROLLUP()
    Dim LASTROW As Long, ROWMULT As Long, BASEQTY As Long, LASTROWROLL As Long, PRTQTY As Long, LEVELS As Long, LASTCOL As Long
    Dim PRT As String, LEVLET As String, DESC As String, UOM As String, MADEFROM As String, GEOCOL As Long, PTYPE As String, GEOM As String
    Dim PRTCOL As Integer, QTYCOL As Integer, LEVELCOL As Integer, MADECOL As Integer, DESCCOL As Integer, UOMCOL As Integer, TYPECOL As Integer
    Dim CAGECOL As Integer, CAGE As String, DWGNUM As String
    Dim REXIST As Boolean, PRTEXIST As Boolean
    Dim LEVELARRAY() As Long
    Dim i As Long, j As Long, CURLEV As Long, NEXTLEV As Long
    Dim DWGCOL As Integer

    PRTCOL = 1
    QTYCOL = 1
    LEVELCOL = 1
    MADECOL = 1
    DESCCOL = 1
    UOMCOL = 1
    TYPECOL = 1
    GEOCOL = 1
    CAGECOL = 1
    DWGCOL = 1
    DWGNUM = ""

    With ActiveWorkbook
        LASTROW = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        LASTCOL = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
        REXIST = False
        PRTEXIST = False

        ' Setting column values to pull data from
        With .Sheets("Sheet1")
            For i = 1 To LASTCOL
                If InStr(1, .Cells(1, i), "ID", vbTextCompare) Then PRTCOL = i
                If InStr(1, .Cells(1, i), "Quantity", vbTextCompare) Then QTYCOL = i
                If InStr(1, .Cells(1, i), "Level", vbTextCompare) Then LEVELCOL = i
                If InStr(1, .Cells(1, i), "Made", vbTextCompare) Then MADECOL = i
                If InStr(1, .Cells(1, i), "Name", vbTextCompare) Then DESCCOL = i
                If InStr(1, .Cells(1, i), "Unit", vbTextCompare) Then UOMCOL = i
                If InStr(1, .Cells(1, i), "Type", vbTextCompare) Then TYPECOL = i
                If InStr(1, .Cells(1, i), "GEOMETRY", vbTextCompare) Then GEOCOL = i
                If InStr(1, .Cells(1, i), "CAGE", vbTextCompare) Then CAGECOL = i
            Next i
        End With

        LEVLET = Split(Cells(1, LEVELCOL).Address, "$")(1)
        LEVELMAX = Application.WorksheetFunction.Max(Range(LEVLET & "1:" & LEVLET & LASTROW))
        LEVELMIN = Application.WorksheetFunction.Min(Range(LEVLET & "1:" & LEVLET & LASTROW))
        CURLEV = LEVELMIN
        LEVELS = LEVELMAX - LEVELMIN + 1
        ReDim LEVELARRAY(LEVELS)

        ' Setting level multipliers to 1
        For i = 1 To LEVELS
            LEVELARRAY(i) = 1
        Next i

        ' Code to create a rollup sheet if it doesn't exist
        For i = 1 To .Sheets.Count
            If .Sheets(i).Name = "Rollup" Then
                REXIST = True
                Exit For
            End If
        Next i
        If REXIST = False Then
            .Sheets.Add.Name = "Rollup"
            With .Sheets("Rollup")
                .Columns("A").NumberFormat = "@"
                .Cells(1, 1) = "PART NUMBER"
                .Cells(1, 2) = "DESCRIPTION"
                .Cells(1, 3) = "ORDER QUANTITY"
                .Cells(1, 4) = "UNIT OF MEASURE"
                .Cells(1, 5) = "MADE FROM"
                .Cells(1, 6) = "PART TYPE"
                .Cells(1, 7) = "GEOMETRY"
                .Cells(1, 8) = "CAGE CODE"
                .Cells(1, 9) = "DRAWING NUMBER"
                .Range("A:Z").AutoFilter
            End With
        End If

        ActiveWorkbook.Sheets("Sheet1").Activate
        With ActiveSheet
            For i = 2 To LASTROW
                CURLEV = .Cells(i, LEVELCOL)
                PRT = .Cells(i, PRTCOL)
                DESC = .Cells(i, DESCCOL)
                UOM = .Cells(i, UOMCOL)
                MADEFROM = .Cells(i, MADECOL)
                PTYPE = .Cells(i, TYPECOL)
                GEOM = .Cells(i, GEOCOL)
                CAGE = .Cells(i, CAGECOL)
                DWGNUM = ""

                If .Cells(i, QTYCOL) = "" Or .Cells(i, QTYCOL) <= 0 Then
                    ROWMULT = 1
                    BASEQTY = 1
                    PRTQTY = BASEQTY
                Else
                    ROWMULT = .Cells(i, QTYCOL)
                    BASEQTY = .Cells(i, QTYCOL)
                    PRTQTY = BASEQTY
                End If

                LEVELARRAY(.Cells(i, LEVELCOL).Value) = ROWMULT

                If CURLEV > LEVELMIN Then
                    For j = i To 2 Step -1
                        If .Cells(j, LEVELCOL) = LEVELMIN Then
                            If .Cells(j, QTYCOL) > 0 Then
                                LEVELARRAY(.Cells(j, LEVELCOL)) = .Cells(j, QTYCOL)
                            Else
                                LEVELARRAY(.Cells(j, LEVELCOL)) = 1
                            End If
                            Exit For
                        End If
                    Next j

                    For j = LBound(LEVELARRAY) To UBound(LEVELARRAY)
                        If j <> CURLEV Then
                            PRTQTY = PRTQTY * LEVELARRAY(j)
                        End If
                    Next j
                End If

                ActiveWorkbook.Sheets("Rollup").Activate
                With ActiveSheet
                    LASTROWROLL = .Cells(Rows.Count, 1).End(xlUp).Row
                    For j = 2 To LASTROWROLL
                        If .Cells(j, 1) = PRT Then
                            PRTEXIST = True
                            .Cells(j, 3) = .Cells(j, 3) + PRTQTY
                            Exit For
                        End If
                    Next j
                    If PRTEXIST = False Then
                        .Cells(LASTROWROLL + 1, 1) = PRT
                        .Cells(LASTROWROLL + 1, 2) = DESC
                        .Cells(LASTROWROLL + 1, 3) = PRTQTY
                        .Cells(LASTROWROLL + 1, 4) = UOM
                        .Cells(LASTROWROLL + 1, 5) = MADEFROM
                        .Cells(LASTROWROLL + 1, 6) = PTYPE
                        .Cells(LASTROWROLL + 1, 7) = GEOM
                        .Cells(LASTROWROLL + 1, 8) = CAGE
                        .Cells(LASTROWROLL + 1, 9) = DWGNUM
                    End If
                End With
                PRTEXIST = False
            Next i
        End With
    End With

    ' New function to create individual tabs for level 2 items
    CreateLevel2Tabs
End Sub

Sub CreateLevel2Tabs()
    Dim ws As Worksheet
    Dim level2Sheet As Worksheet
    Dim LASTROW As Long
    Dim i As Long
    Dim PRT As String
    Dim level2Items As Collection
    Set level2Items = New Collection

    Set ws = ThisWorkbook.Sheets("Rollup")
    LASTROW = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Collect level 2 items
    For i = 2 To LASTROW
        If ws.Cells(i, 3).Value = 2 Then ' Assuming column 3 is the level column
            PRT = ws.Cells(i, 1).Value
            On Error Resume Next
            level2Items.Add PRT, CStr(PRT) ' Use PRT as key to avoid duplicates
            On Error GoTo 0
        End If
    Next i

    ' Create individual tabs for each level 2 item
    For Each PRT In level2Items
        On Error Resume Next
        Set level2Sheet = ThisWorkbook.Sheets(PRT)
        If level2Sheet Is Nothing Then
            Set level2Sheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
            level2Sheet.Name = PRT
        End If
        On Error GoTo 0

        ' Copy relevant data to the new sheet
        ws.Rows(1).Copy Destination:=level2Sheet.Rows(1) ' Copy headers
        For i = 2 To LASTROW
            If ws.Cells(i, 1).Value = PRT Then
                ws.Rows(i).Copy Destination:=level2Sheet.Rows(level2Sheet.Cells(level2Sheet.Rows.Count, 1).End(xlUp).Row + 1)
            End If
        Next i
    Next PRT
End Sub

I attempted to try, but I don't really have any skills in VBA so most of it is copy/paste rather than trying to learn at the moment. This would make me the man around the office.