Creating a clone product under selected root assy

This code was supposed to create a cloned product under the selected root assembly with the exact same structure. Instead, it is creating only a component assembly, as shown in the image. I need it to create a normal product, not a component

The code is used to create a dummy clone under the selected root assembly and paste it there. It works, but it always creates the clone as a component, which means I cannot open it in a new window. I need the code to create it as a product instead, so I can open it in another window

Option Explicit
enter image description here
Dim ProductCounter As Integer

Sub CreateProductTreeClone()
    Dim CATIA As Object
    Set CATIA = GetObject(, "CATIA.Application")

    If CATIA.Documents.Count = 0 Then
        MsgBox "No document open.", vbExclamation
        Exit Sub
    End If

    Dim activeDoc As Document
    Set activeDoc = CATIA.ActiveDocument

    If TypeName(activeDoc) <> "ProductDocument" Then
        MsgBox "Active document must be a ProductDocument (assembly).", vbExclamation
        Exit Sub
    End If

    Dim sel As Selection
    Set sel = activeDoc.Selection
    If sel.Count <> 1 Or TypeName(sel.Item(1).Value) <> "Product" Then
        MsgBox "Select exactly one root product node to clone.", vbExclamation
        Exit Sub
    End If

    Dim rootProd As Product
    Set rootProd = activeDoc.Product
    Dim rootSelectedProd As Product
    Set rootSelectedProd = sel.Item(1).Value

    ' Main product is 000product1B
    ProductCounter = 1
    Dim newRootProd As Product
    Set newRootProd = rootProd.Products.AddNewProduct("000product" & ProductCounter & "B")
    newRootProd.Name = "000product" & ProductCounter & "B"
    newRootProd.PartNumber = "000product" & ProductCounter & "B"

    ' Use CATIA.ActiveDocument.Selection for reliable copy/paste
    CopyStructureRecursive rootSelectedProd, newRootProd, CATIA.ActiveDocument.Selection, newRootProd.Name

    MsgBox "Created new product tree '" & newRootProd.Name & "' with cloned structure.", vbInformation
End Sub

Sub CopyStructureRecursive(ByVal sourceProd As Product, ByVal targetProd As Product, ByRef sel As Selection, ByVal newProdName As String)
    Dim i As Integer
    Dim child As Product
    Dim partDoc As Document

    For i = 1 To sourceProd.Products.Count
        Set child = sourceProd.Products.Item(i)

        ' Prevent infinite recursion
        If child.Name <> newProdName Then
            On Error Resume Next
            Set partDoc = child.ReferenceProduct.Parent
            On Error GoTo 0

            If child.Products.Count > 0 Then
                ' Next sub-assembly: increment counter, generate new name
                ProductCounter = ProductCounter + 1
                Dim subProdName As String
                subProdName = "000product" & ProductCounter & "B"
                Dim newSubProd As Product
                Set newSubProd = targetProd.Products.AddNewProduct(subProdName)
                newSubProd.Name = subProdName
                newSubProd.PartNumber = subProdName

                CopyStructureRecursive child, newSubProd, sel, newProdName
            ElseIf Not partDoc Is Nothing And TypeName(partDoc) = "PartDocument" Then
                ' Leaf part: copy-paste
                sel.Clear
                sel.Add child
                sel.Copy
                sel.Clear
                sel.Add targetProd.Products
                sel.Paste
            End If
        End If
    Next i
End Sub

AddNewProduct creates a component not an new ProductDoument.
Use AddNewComponent to create a new ProductDocument and add it to the Products-collection

Example:

Set newRootProd = rootProd.Products.AddNewComponent("Product", "000product" & ProductCounter & "B")
'and if the subproduct shall be a ProductDocument too
Set newSubProd = targetProd.Products.AddNewComponent("Product", subProdName)