try:
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
'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.Range(Start:=.Selection.Range.End, End:=.Selection.Range.End)
'Set StartPosn = docWord.Sections.First.Range.Tables(1).Rows(2).Cells(1).Range '.Paragraphs(1).Range.Characters.Last
Set StartPosn = docWord.Tables(1).Rows(2).Cells(1).Range.Characters.first '.Paragraphs(1).Range.Characters.Last
'StartPosn.Select
With StartPosn
Debug.Print Len(StartPosn)
'.collapseStart
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
You can delete all the comments.
I've assumed the first table in the .dot file.