p45cal your a star, I just defined BulletCount and myCount as integers and it works perfect. Here is my final code.

Sub NewList()
    Dim pappWord As Object, docWord As Object, wb As Excel.Workbook
    Dim TodayDate As String, Path As String, sNewFileName As String, sSaveAs As String, sSaveIn As String
    Dim rangetocopy As Range, StartPosn, cll As Range
    Dim BulletCount As Integer, myCount As Integer
    
     'On Error GoTo ErrorHandler  're-enable
    Set rangetocopy = Intersect(Range("A7").CurrentRegion, Columns(1))
    If Application.CountIf(rangetocopy.Offset(, 1), "Y") > 0 Then
        Set wb = ActiveWorkbook
        TodayDate = Format(Date, "mmmm d, yyyy")
        Path = wb.Path & "\NewList.dot"
        sNewFileName = Range("G1").Value
        sSaveIn = Range("G3").Value
        sSaveAs = sSaveIn & "\" & sNewFileName & " " & Format(Date, "DD-MMM") & " " & ".doc"
        
         'Create a new Word Session
        Set pappWord = CreateObject("Word.Application")
         'Open document in word
        With pappWord
            Set docWord = .Documents.Add(Path)
            docWord.SaveAs sSaveAs
             'Activate word and display document
            .Visible = True
            .ActiveWindow.WindowState = 1
            .Activate
   
            Set StartPosn = docWord.Tables(1).Rows(2).Cells(1).Range.Characters.first
            With StartPosn
                Debug.Print Len(StartPosn)
                BulletCount = Application.CountIf(rangetocopy.Offset(, 1), "Y")
                myCount = 0
                For Each cll In rangetocopy.Cells
                    If cll.Offset(, 1) = "Y" Then
                        myCount = myCount + 1
                        .InsertAfter cll.Text
                        StartPosn.Paragraphs(StartPosn.Paragraphs.Count).Range.Font.Bold = cll.Offset(, 2) = "Y"
                        If myCount < BulletCount Then .insertparagraphafter
                    End If
                Next cll
               
                 'add bullets:
                If Len(StartPosn) > 2 Then
                    StartPosn.ListFormat.ApplyBulletDefault
                End If
            End With
        End With
    Else
        MsgBox "No data to copy"
    End If
    
     'Release the Word object to save memory and exit macro
ErrorExit:
    Set pappWord = Nothing
    Exit Sub
     
     'Error Handling routine
ErrorHandler:
    If Err Then
        MsgBox "Error No: " & Err.Number & "; There is a problem"
        If Not pappWord Is Nothing Then
            pappWord.Quit False
        End If
        Resume ErrorExit
    End If
End Sub

Thank you