Copy text in excel cells and paste as bullets into new word doc

[olivierpbeland]

Dear excel gurus,
I have a simple excel sheet with columns A (name1) B (name2) C (name3) D (name4) E (name5) F (text). A given name can only appear once in any given row.

I am looking for a vba code (Excel 2003) that would loop through cells in A1:E?? (number of rows varies, loop needs to find last non-empty row in column A) and look for a particular name (e.g. "Stefan Thomas"):
1) create new unnamed word doc
2) Put "New Annex" as a header (top right) in the new word doc
3) Insert text "List for Stefan Thomas" centered and underlined as the first line of the new word doc. The document will have two sections:
4) Insert text "Items in Column A" bolded and aligned to the left
5) Insert text "Items in Column B to E" bolded and aligned to the left below the section in 4
6) if "Stefan Thomas" is in column A, copy text in column F and paste in word doc as first bullet (below title "Items in Column A")
7) repeat step 6 for all other instances of "Stefan Thomas" in column A (append text as next bullet in section "Items in Column A")
8) If "Stefan Thomas" is in column B or C or D or E (can only appear once per row), copy text in column F and paste in word doc as first bullet (below title "Items in Column B to E")
9) repeat step 8 for all other instances of "Stefan Thomas" in column B or C or D or E (append text as next bullet in section "Items in Column B to E")

Infinite thanks for your help!

PS: would appreciate if you could indicate in the code how I can choose the type of bullet as well as space between bullets and font type

 

[olivierpbeland]

Please let me know if this is not clear or simply not doable. Thanks!

cross post at http://www.excelforum.com/showthread.php?t=965764

 

[olivierpbeland]

Bump because no reply yet

 

[olivierpbeland]

Bumping again...

 

[Cindy Ellis]

Hello, and welcome to Mr. Excel.
I have read your post a few times now, and I think I finally understand what you are asking, but I have a few questions.
First, how will the user choose the name to be selected for a given report? Or do you want the macro to first identify all of the unique names in cells A through E, and create a report for each of them without any prompt?
Where do you want the word document(s) to be saved...the current directory (containing the Excel file), or somewhere else? Any specific filename?

Hoping to help,

 

[olivierpbeland]

Hello, and welcome to Mr. Excel.
I have read your post a few times now, and I think I finally understand what you are asking, but I have a few questions.
First, how will the user choose the name to be selected for a given report? Or do you want the macro to first identify all of the unique names in cells A through E, and create a report for each of them without any prompt?
Where do you want the word document(s) to be saved...the current directory (containing the Excel file), or somewhere else? Any specific filename?

Hoping to help,

Thanks for the reply. The name is located in a cell in the same worksheet say cell G1. The code should only look for that particular name. I would prefer that the file is not saved (the user would decide whether to save and if so to what location). Let me know if this is not clear. And thanks again for helping with this!

 

[Cindy Ellis]

OK...it took a while because of other commitments, but give this a try. There are still a couple of "rough edges" (potentially inefficient Word VBA code, extra bullets, etc.) but it seems to do what you requested.
Before running this, you will need to add a reference to the Word object library in the visual basic editor (if you haven't already added it). I tested it on a workbook with a few hundred data rows, mocked up based on your description of the data. Also, it won't work if you leave out the "Option Base 1" statement. The "Option Explicit" statement should be left in if you modify the code, since it will catch un-declared variable.

Option Explicit
Option Base 1


Sub MakeReport()
'*******************
' This macro will create 2 lists of Column F items for a selected individual,
'   one list for each instance of the name in Column A,
'   and one list for each instance of the name in columns B-E
'*******************
'STEP 0
' Declare all necessary variables
'*******************
Dim SelectedName As String
Dim ColumnA_Array() As String
Dim ColumnB2E_Array() As String
Dim LastDataRow As Long
Dim ColumnA_Item As Long
Dim ColumnB2E_Item As Long
Dim i As Long, j As Long, k As Long


Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim wrdTable As Word.Table
Dim wrdRange As Word.Range


Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Add ' create a new document
Set wrdRange = wrdDoc.Range 'creates a variable to track position in the word doc if needed


'*******************
' STEP 1
' Get the data from Excel
'*******************


SelectedName = ActiveSheet.Range("G1").Value
LastDataRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ReDim ColumnA_Array(LastDataRow)
ReDim ColumnB2E_Array(LastDataRow)
j = 1
k = 1


For i = 1 To LastDataRow
    If ActiveSheet.Cells(i, 1) = SelectedName Then
        ColumnA_Array(j) = ActiveSheet.Cells(i, 6).Value
        j = j + 1
    End If
    If (ActiveSheet.Cells(i, 2) = SelectedName) Or (ActiveSheet.Cells(i, 3) = SelectedName) Or (ActiveSheet.Cells(i, 4) = SelectedName) Or (ActiveSheet.Cells(i, 5) = SelectedName) Then
        ColumnB2E_Array(k) = ActiveSheet.Cells(i, 6).Value
        k = k + 1
    End If


Next i


'*******************
' STEP 2
' Create a new Word Document.  Note: A reference to the Word object library is required to run this macro
'*******************


wrdApp.Visible = True
 
'*******************
'STEP 3
' Add header
'*******************
 
    With wrdApp.ActiveDocument
        With .Sections(1)
            .Headers(wdHeaderFooterPrimary).Range.Text = vbTab & vbTab & "New Annex"
        End With
    End With
'*******************
'STEP 4
' Insert text "List for (SelectedName) centered and underlined as the first line of the new word doc.
'*******************
    wrdRange.Collapse Direction:=wdCollapseEnd
        
    With wrdApp.Selection
        .TypeText Text:="List for " & SelectedName
        .ParagraphFormat.Alignment = wdAlignParagraphCenter
        .TypeParagraph
        .TypeParagraph


        .HomeKey Unit:=wdStory
'        .Extend
        .EndKey Unit:=wdLine, Extend:=wdExtend
        .Font.Bold = wdToggle
        With .Borders(wdBorderBottom)
            .LineStyle = Options.DefaultBorderLineStyle
            .LineWidth = Options.DefaultBorderLineWidth
            .Color = Options.DefaultBorderColor
        End With
        .EndKey Unit:=wdStory
        
        wrdRange.Collapse Direction:=wdCollapseEnd


'*******************
'STEP 5
' Insert text "Items in Column A" bolded and aligned to the left, then items bulleted below
'*******************
        .MoveUp Unit:=wdLine, Count:=1
        .TypeText Text:="Items in Column A"
'        .Extend
        .HomeKey Unit:=wdLine, Extend:=wdExtend
        .Font.Bold = wdToggle
    
        With .ParagraphFormat
            .SpaceBefore = 12
            .SpaceBeforeAuto = False
            .SpaceAfter = 0
            .SpaceAfterAuto = False
            .LineSpacingRule = wdLineSpaceSingle
            .Alignment = wdAlignParagraphLeft
        End With
        
        wrdRange.Collapse Direction:=wdCollapseEnd
        
        '**********
        .MoveDown Unit:=wdLine, Count:=1
    .ParagraphFormat.Alignment = wdAlignParagraphLeft
    End With
    
        wrdDoc.Paragraphs(3).Range.ListFormat.ApplyBulletDefault
    For ColumnA_Item = 1 To j
        With wrdApp.Selection
        wrdRange.Collapse Direction:=wdCollapseEnd
        .TypeText Text:=ColumnA_Array(ColumnA_Item)
        .TypeParagraph
       End With
    Next ColumnA_Item


    wrdRange.Collapse Direction:=wdCollapseEnd
 '*******************
'STEP 6
' Insert text "Items in Column B-E" bolded and aligned to the left, then items bulleted below
'*******************
       
    With wrdApp.Selection


        .TypeText Text:="Items in Columns B-E"
        .ParagraphFormat.Alignment = wdAlignParagraphLeft
        .HomeKey Unit:=wdLine, Extend:=wdExtend
        .Font.Bold = True
        .Range.ListFormat.RemoveNumbers NumberType:=wdNumberParagraph
        .Collapse Direction:=wdCollapseEnd
        .TypeParagraph
        .Range.ListFormat.ApplyBulletDefault
        .Font.Bold = False


    End With
    
    For ColumnB2E_Item = 1 To k
        With wrdApp.Selection
        wrdRange.Collapse Direction:=wdCollapseEnd
        .TypeText Text:=ColumnB2E_Array(ColumnB2E_Item)
        .TypeParagraph
       End With
    Next ColumnB2E_Item


End Sub

Hope this helps,

 

[olivierpbeland]

You are the best! I will try it and get back to you.
Thanks so much for the help.

 

[olivierpbeland]

Wonderful! I have modified a bit and solved the extra-bullets problems (loop over ColumnA_Item from 2 to j and the .TypeParagraph only applies if ColumnA_Item < j). Similar thing for the other items for ColumnB2E_Item.

Only thing left for me would be how to change the bullet format (from default to "O").

Any clue?