Word Report using excel database

[samfolds]

Hello all,

I'm looking for a way to save/print several reports by changing only certain information in that report. Those information are placed in an excel database and all I want to do is somehow create a word template and link each column to a certain place. For example, say my excel database had the columns :

NamesAddressPhoneSam1234 pool st.123-456-7891Jack4321 sack st.323-525-9874Gil654 8th avenue325-525-8787Andrew987 9th st.322-252-5252

And my reports looks like this :

*****************************************
Hello "NAME",

blablablabla "PHONE" blablablabla.

blablablablablabla "ADDRESS".
*****************************************


I would like to loop through all the rows (1 report per row) and save the report in the form : Report-2010-"NAME".doc ...

Can someone enlight me on how to do that?

Thank you very much.

Samfolds

 

[Macropod]

I think the issue is that, upon updating, the bookmark and, hence, its name, are both deleted. Try:

Dim i As Long, StrBmk As String
    For i = oDoc.Bookmarks.Count To 1 Step -1
        With oDoc.Bookmarks(i)
            StrBmk = .Name
            Set objX = wsData.Rows(1).Find(StrBmk, LookIn:=xlValues, LookAt:=xlWhole)
            If Not objX Is Nothing Then
            ' found
                Set BmkRng = .Range
                If Right(StrBmk, 4) = "Date" Then
                    BmkRng.Text = Format(wsData.Cells(rng2.Row, objX.Column), "dd mmmm yyyy")
                ElseIf Right(StrBmk, 6) = "Amount" Then
                    BmkRng.Text = Format(wsData.Cells(rng2.Row, objX.Column), "£#,##0.00")
                Else
                    BmkRng.Text = wsData.Cells(rng2.Row, objX.Column)
                End If
                oDoc.Bookmarks.Add StrBmk, BmkRng
            Else
                MsgBox "Bookmark '" & StrBmk & "' not found", vbOKOnly + vbCritical, "Error"
                GoTo Tidy_Exit
            End If
        End With
    Next

 

[venkateshr]

Hi, Thank you very much for the code and procedure. You were been great help for me today. Can you please also tell me how to activate this code in command button (for example- if i click the command button this code should work) can you please help me......today is my first day in office and i have to do this....pls help me ASAP

 

[Macropod]

Have you tried adding the code (except for the opening Sub & ending End Sub lines) to your command button, or simply calling the existing sub from your command button? Either approach should work.

 

[venkateshr]

Thanks for your reply Paul, its working now....

Can you also please suggest me how can i learn writing macro.

Regards,
Venkatesh

 

[Macropod]

You could buy some vba programming textbooks for whatever Office applications you're concerned with (eg Word, Excel Access), do a course, and/or study the code you'll find in forums like this one.

 

[venkateshr]

You could buy some vba programming textbooks for whatever Office applications you're concerned with (eg Word, Excel Access), do a course, and/or study the code you'll find in forums like this one.

Dear Friends,

I tried this macro for another file by following all the steps i am getting "Runtime error 424 Object required". when i checked debug the below mentioned code is highlighted in yellow colour.. can anybody help me to solve this pls

strDocumentFolder = wsControl.[Document_Folder].Value

Below the excel file details which i have maintained in data sheet for your referece

Coloum A	Coloum B	Coloum C	Coloum D	Coloum E	Coloum F	Coloum G	Coloum H	Coloum I	Coloum J
First_Name	Role Hired For	Notice_Period	Date of Joining	Basic_Salary	Shift_allowance	Annual	Medical	Document Name	Template Name
Bosco	Senior Executive	30	22-Oct-13	30,000.00	1,000.00	12	10	Offer Proposal Form.docx	Offer Proposal Form.docx

and the control sheet contains the below details

Template Folder	D:\Macro Employee Contract Advise\Letter CreatorWord Templates
Data worksheet	Data Sheet
Document Folder	D:\Macro Employee Contract Advise\Letter CreatorDocuments

Regards,
Venkatesh

 

[Macropod]

Are you sure you've followed all of the steps in posts 4 & 5? The error message suggests you haven't.

 

[djsban]

Are you sure you've followed all of the steps in posts 4 & 5? The error message suggests you haven't.

I agree with venkateshr - I've followed all of the instructions in this post and get the same error.

This would be a great tool and I'd be really interested in anyone's thoughts on what is causing this error....and how I can fix it of course!

Any help appreciated!

Full code is copied below:

Option Explicit
Sub Create_Letters()
' Note: you will need to add error-trapping
Dim objX As Object
Dim rng1 As Range
Dim rng2 As Range
Dim wb As Workbook
Dim wsControl As Worksheet
Dim wsData As Worksheet
'
Dim oApp As Word.Application
Dim oBookMark As Word.Bookmark
Dim oDoc As Word.Document
'
Dim strDocumentFolder As String
Dim strTemplate As String
Dim strTemplateFolder As String
Dim lngTemplateNameColumn As Long
Dim strWordDocumentName As String
Dim lngDocumentNameColumn As Long
Dim lngRecordKount As Long ' not used but retained for future use
'
Set wb = ThisWorkbook
Set wsControl = wb.Worksheets("Control Sheet")
wsControl.Activate
Set wsData = wb.Worksheets(wsControl.[Data_Sheet].Value)
strTemplateFolder = wsControl.[Template_Folder].Value
strDocumentFolder = wsControl.[Document_Folder].Value
wsData.Activate
lngTemplateNameColumn = wsData.[Template_Name].Column
lngDocumentNameColumn = wsData.[Document_Name].Column
' number of letters required:
' must not have any blank cells in column A - except at the end
Set rng1 = wsData.Range(Cells(2, 1), Cells(Rows.Count, 1).End(xlUp))
lngRecordKount = rng1.Rows.Count
'
'Set oApp = CreateObject("Word Application")
Set oApp = New Word.Application
' Process each record in turn
For Each rng2 In rng1
    strTemplate = strTemplateFolder & "\" & wsData.Cells(rng2.Row, lngTemplateNameColumn)
    strWordDocumentName = strDocumentFolder & "\" & wsData.Cells(rng2.Row, lngDocumentNameColumn)
    ' check that template exists
    If Dir(strTemplate) = "" Then
        MsgBox strTemplate & " not found"
        GoTo Tidy_Exit
    End If
    Set oDoc = oApp.Documents.Add
    oApp.Selection.InsertFile strTemplate
    ' locate each bookmark
    For Each oBookMark In oDoc.Bookmarks
        Set objX = wsData.Rows(1).Find(oBookMark.Name, LookIn:=xlValues, LookAt:=xlWhole)
        If Not objX Is Nothing Then
            ' found
            If Right(oBookMark.Name, 4) = "Date" Then
                oBookMark.Range.Text = Format(wsData.Cells(rng2.Row, objX.Column), "dd mmmm yyyy")
            ElseIf Right(oBookMark.Name, 6) = "Amount" Then
                oBookMark.Range.Text = Format(wsData.Cells(rng2.Row, objX.Column), "£#,##0.00")
            Else
                oBookMark.Range.Text = wsData.Cells(rng2.Row, objX.Column)
            End If
        Else
            MsgBox "Bookmark '" & oBookMark.Name & "' not found", vbOKOnly + vbCritical, "Error"
            GoTo Tidy_Exit
        End If
    Next oBookMark
    '
    oDoc.SaveAs strWordDocumentName
    oDoc.Close
Next rng2
'
Tidy_Exit:
On Error Resume Next
Set oDoc = Nothing
Set oBookMark = Nothing
Set objX = Nothing
Set rng1 = Nothing
Set rng2 = Nothing
oApp.Quit
Set oApp = Nothing
'
Set wsData = Nothing
Set wsControl = Nothing
Set wb = Nothing
'
End Sub

 

[Macropod]

Frankly, I don't have time to go through all the steps required to implement, test & (probably not) debug the code. The original code, when implemented as per the directions given, worked. I later supplied some enhancements.

IMHO, though, the entire project would be better managed via a mailmerge, perhaps coupled with a document-splitter macro (see, for example Document Splitter). Alternatively, one could just as easily use one of the Many-to-One Mail Merge add-ins, from:
Graham Mayor at http://www.gmayor.com/ManyToOne.htm; or
Doug Robbins at https://skydrive.live.com/?cid=5aed...!cid=5AEDCB43615E886B&id=5AEDCB43615E886B!566

 

[osnola ibax]

Hi there, I have followed all the steps, took about an hour maybe. Its brilliant. However, is there any amendment I could make that would just allow me to merge one row of data from the data spreadsheet at a time. In other words select from an active row or something like that.