PDA

View Full Version : [SOLVED] Excel VBA - Open Word template and create bulleted list based on cell values



reefaman
06-24-2014, 02:43 PM
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,


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

reefaman
06-25-2014, 02:53 AM
Here is a pic of what I would like to achieve.
Thanks11867

p45cal
06-29-2014, 09:56 AM
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)
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?184-A-message-to-forum-cross-posters
regarding cross-posting.

snb
06-29-2014, 02:17 PM
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

p45cal
06-29-2014, 04:28 PM
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:
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

snb
06-30-2014, 02:43 AM
@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:


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

reefaman
07-01-2014, 05:58 AM
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.

p45cal
07-01-2014, 07:46 AM
my template which has a 2 row 1 column table with the bulleted list in the second rowCan you confirm that you want the entire bulleted list in the 1st cell of the 2nd row.

reefaman
07-01-2014, 11:32 AM
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.

p45cal
07-01-2014, 02:59 PM
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.

reefaman
07-01-2014, 08:11 PM
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 :thumb