Excel VBA - Open Word template and create bulleted list based on cell values

Hello,
I have a sheet(Sheet2) with a list in column A starting in cell A7 going to A100. From Excel I would like to be able to open a Word template and create a selective bulleted list based on a “Y” being in the corresponding cell in column B. I would also like to make the item in the list bold if there is a “Y” in the corresponding cell in column C. I have the following code, copied from various forums, which opens the template and saves it with a timestamp but does not create the list. Can anyone help?
If it is not possible to create a bulleted list or make selected items bold, can I just produce the selective list?
I am using Office 2007 on Windows 7.
Thanks,

Code:

---

Option Explicit
 
 
Sub NewList()
   
   
    Dim pappWord As Object
    Dim docWord As Object
    Dim wb As Excel.Workbook
    Dim xlName As Excel.Name
    Dim TodayDate As String
    Dim Path As String
    Dim sNewFileName As String
    Dim sSaveAs As String
    Dim sSaveIn As String
    Dim rangetocopy As Range
   
   
    Set rangetocopy = Range("A7").CurrentRegion
    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"
   
   
    On Error Goto ErrorHandler
   
   
    'Create a new Word Session
    Set pappWord = CreateObject("Word.Application")
   
   
    On Error Goto ErrorHandler
   
   
    'Open document in word
    Set docWord = pappWord.Documents.Add(Path)
    pappWord.ActiveDocument.SaveAs sSaveAs
   
   
    'Activate word and display document
    With pappWord
        .Visible = True
        .ActiveWindow.WindowState = 1
        .Activate
       
       
        'Paste the copied contents
        Selection.GoTo What:=wdGoToLine, Which:=wdGoToRelative, Count:=4
        rangetocopy.Copy
        docWord.Words(1).PasteExcelTable False, False, False
    End With
   
   
    '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

---

Here is a pic of what I would like to achieve.
ThanksAttachment 11867

try:

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

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)
  End With
  With docWord
    StartPosn.insertparagraphbefore
    Set StartPosn = .Range(StartPosn.End + 1, StartPosn.End + 1)
    For Each cll In rangetocopy.Cells
      If cll.Offset(, 1) = "Y" Then
        StartPosn.InsertAfter cll.Text
        StartPosn.insertparagraphafter
        StartPosn.Paragraphs(StartPosn.Paragraphs.Count).Range.Font.Bold = cll.Offset(, 2) = "Y"
      End If
    Next cll
    'add bullets:
    If Len(StartPosn) > 0 Then StartPosn.ListFormat.ApplyBulletDefault
  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

---

At the moment it places the list at the top of the document (wherever the selection is) because it wasn't clear where you wanted it (a few lines down or to replace the first word).

You have cross posted here:
http://www.ozgrid.com/forum/showthread.php?t=189213
Have a read of this:
http://www.excelguru.ca/content.php?...-cross-posters
regarding cross-posting.

Code:

---

Sub M_snb()
    sn = Columns(1).SpecialCells(2)
    sp = sn
   
    For j = 1 To UBound(sn)
      sp(j, 1) = Columns(1).Cells(1)(j).Font.Bold
    Next
   
    With CreateObject("Word.document")
        .Content = Join(Application.Transpose(sn), vbCr)
        For j = 1 To UBound(sp)
          .Paragraphs(j).Range.Font.Bold = sp(j, 1)
        Next
        .Content.ListFormat.ApplyListTemplateWithLevel ListGalleries(1).ListTemplates(1)
    End With
End Sub

---

snb,
The bold/not bold info is in column C, none of the data in column A appears to be bold, only a Y in column C designates that it is to be made bold in Word.
The line sp(j, 1) = Columns(1).Cells(1)(j).Font.Bold seems to be looking at cell A1 and down when the information is not there (it should start in A7 too).
There doesn't seem to be any excluding of data which doesn't have a Y in column B.
I tried doing more in-memory processing like you, but I don't know how to put only the filtered data into an array slickly, so this is just an attempt and doesn't address use of a word template, nor where in the word document to place the results:

Code:

---

Sub blah()
With ActiveSheet.Range("A6:C100")
  .AutoFilter Field:=2, Criteria1:="Y"
  .Resize(.Rows.Count - 1).Offset(1).SpecialCells(xlCellTypeVisible).Copy
  With Sheets.Add
    .Paste
    sss = .UsedRange
    Application.DisplayAlerts = False: .Delete: Application.DisplayAlerts = True
  End With
  .AutoFilter
End With
With CreateObject("Word.document")
  .Content = Join(Application.Transpose(Application.Index(sss, 0, 1)), vbCr)
  For j = 1 To UBound(sss)
    .Paragraphs(j).Range.Font.Bold = (sss(j, 3) = "Y")
  Next
  '.Content.ListFormat.ApplyListTemplateWithLevel ListGalleries(1).ListTemplates(1)'needs a ref to Word.
  .Content.ListFormat.ApplyBulletDefault
  .Parent.Visible = True
End With
End Sub

---

@p45cal

I only offer an approach (not a solution) to achieve what has been asked for in the title of this thread.
I suppose the OP can modify the methods I suggest to her/his situation.
I alsop assumed the creating of the bulleted list in Word and the formatting of the items in Word to be the core of the question.

In your code the autofilter can be done with:

Code:

---

With ActiveSheet.Range("A6:C100")
        .AutoFilter 2, "Y"
        .Copy cells(1,20)
        .AutoFilter
end with
sn=cells(1,20).currentregion
cells(1,20).currentregion.clearcontents

---

Thanks p45cal and snb for your replies much appreciated.

I have found success with p45cal's first reply when opening a blank template. Populating the list works perfectly as I want. Unfortunately it does not work with my template which has a 2 row 1 column table with the bulleted list in the second row, the first row is just a heading, I should have made this clear in my original post. Is there anyway to place the start point in the second row?

I am sorry for the cross post, I am new to this and was not aware of the rules. Thank you for pointing this out to me and I will refrain in future.

Quote:

---

Originally Posted by reefaman

my template which has a 2 row 1 column table with the bulleted list in the second row

---

Can you confirm that you want the entire bulleted list in the 1st cell of the 2nd row.

Quote:

---

Originally Posted by p45cal

Can you confirm that you want the entire bulleted list in the 1st cell of the 2nd row.

---

Yes that is what I would like to achieve if possible.

try:

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

'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.

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

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 :thumb