Speed up excel to word VBA

2 Attachment(s)

Attachment 237 Attachment 238

Hello
I need to create about 100 word reports from an excel "database"
Please help me with speeding up the following code:

Code:

'------------------------------------------ ' Working 2012-05-15 '------------------------------------------ Option Explicit Sub WordGenerate() Dim CL As Range, rdata As Range, filt As Range Dim UniqueClient As Range, CUniqueClient As Range, Dest As Range Dim Client As String, RM() As String, TA() As String, TA_Email() As String, TA_Phone() As String Dim ContractTYPE() As String, Supplier() As String, FundID() As String, FundName() As String, Email() As String Dim Phone() As String, Mobile() As String, JobTitle() As String, Initials() As String, Surname() As String Dim i As Integer, j As Integer, k As Integer, y As Integer, Speed As Date Dim wrdApp As Object, tmpDoc As Object, wrdDoc As Object, WRng As Object, wrdRange As Object Dim WDoc As String, myDoc As String, x As String, Path As String, t As String, MyName As String Dim strBar As String Dim lngLoop As Integer Application.ScreenUpdating = False Application.EnableEvents = False Speed = Now() With Worksheets("DB") Set CL = Range(.Range("A1"), .Range("A1").End(xlDown)) Set UniqueClient = .Range("A1").End(xlDown).Offset(5, 0) CL.AdvancedFilter xlFilterCopy, , UniqueClient, True Set UniqueClient = Range(UniqueClient.Offset(1, 0), UniqueClient.End(xlDown)) Set rdata = .Range("A1").CurrentRegion rdata.Sort key1:=.Range("A1"), header:=xlYes MyName = ThisWorkbook.Path myDoc = "Fund Purchasing Report - Template.doc" WDoc = MyName & Application.PathSeparator & myDoc On Error Resume Next MkDir MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") On Error GoTo 0 i = 1 For Each CUniqueClient In UniqueClient x = CUniqueClient.Value lngLoop = UniqueClient.Rows.Count rdata.AutoFilter field:=1, Criteria1:=x Set filt = rdata.Offset(1, 0).Resize(rdata.Rows.Count - 1).SpecialCells(xlCellTypeVisible) Client = filt.Areas(1).Cells(1, "A").Value j = filt.Areas(1).Rows.Count i = i + 1 strBar = String(Round(i / lngLoop * 15, 0), ChrW(&H25A0)) & String(15 - Round(15 * i / lngLoop, 0), ChrW(&H25A1)) Application.StatusBar = strBar & Format((i - 1) / lngLoop, " 0%") & " Save report for: " & x ReDim RM(1 To j) ReDim TA(1 To j) ReDim ContractTYPE(1 To j) ReDim Supplier(1 To j) ReDim FundID(1 To j) ReDim FundName(1 To j) ReDim Email(1 To j) ReDim Phone(1 To j) ReDim Mobile(1 To j) ReDim JobTitle(1 To j) ReDim Initials(1 To j) ReDim Surname(1 To j) ReDim TA_Email(1 To j) ReDim TA_Phone(1 To j) For k = 1 To j Client = filt.Areas(1).Cells(k, "A").Value RM(k) = filt.Areas(1).Cells(k, "B").Value TA(k) = filt.Areas(1).Cells(k, "C").Value ContractTYPE(k) = filt.Areas(1).Cells(k, "E").Value Supplier(k) = filt.Areas(1).Cells(k, "F").Value FundID(k) = filt.Areas(1).Cells(k, "H").Value FundName(k) = filt.Areas(1).Cells(k, "I").Value Email(k) = filt.Areas(1).Cells(k, "J").Value Phone(k) = filt.Areas(1).Cells(k, "K").Value Mobile(k) = filt.Areas(1).Cells(k, "L").Value JobTitle(k) = filt.Areas(1).Cells(k, "M").Value Initials(k) = filt.Areas(1).Cells(k, "N").Value Surname(k) = filt.Areas(1).Cells(k, "O").Value TA_Email(k) = filt.Areas(1).Cells(k, "P").Value TA_Phone(k) = filt.Areas(1).Cells(k, "Q").Value Next k '----------------------------------------------------------------------------- On Error Resume Next For k = 1 To j MkDir MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") & Application.PathSeparator & Surname(k) Next k On Error GoTo 0 '----------------------------------------------------------------------------- On Error Resume Next Set wrdApp = GetObject(, "Word.Application") If wrdApp Is Nothing Then ' no current word application Set wrdApp = CreateObject("Word.application") Set wrdDoc = wrdApp.Documents.Open(WDoc) wrdApp.Visible = False Else ' word app running For Each tmpDoc In wrdApp.Documents If StrComp(tmpDoc.FullName, WDoc, vbTextCompare) = 0 Then ' this is your doc Set wrdDoc = tmpDoc Exit For End If Next If wrdDoc Is Nothing Then ' not open Set wrdDoc = wrdApp.Documents.Open(WDoc) End If End If '----------------------------------------------------------------------------- Set wrdRange = wrdDoc With wrdDoc wrdApp.Selection.Style = "DocTitle" wrdApp.Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft wrdApp.Selection.Font.Color = RGB(166, 166, 166) 'Title wrdApp.Selection.Font.Name = "Georgia" wrdApp.Selection.Font.Size = 26 wrdApp.Selection.ParagraphFormat.SpaceAfter = 18 wrdApp.Selection.ParagraphFormat.LineSpacingRule = "At least" wrdApp.Selection.ParagraphFormat.LineSpacing = 13 wrdApp.Selection.TypeText Text:="Trader SRL" wrdApp.Selection.TypeParagraph wrdApp.Selection.Font.Color = RGB(51, 51, 153) 'Title wrdApp.Selection.Font.Name = "Georgia" wrdApp.Selection.Font.Size = 23 wrdApp.Selection.ParagraphFormat.SpaceAfter = 0 wrdApp.Selection.ParagraphFormat.LineSpacing = 0 wrdApp.Selection.TypeText Text:="Report for" wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeText Text:=Client wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph '--------------------------------------------------------------------------- Funds on first page wrdApp.Selection.Style = "DocSubtitle" For k = 1 To j wrdApp.Selection.Font.Color = RGB(255, 0, 0) wrdApp.Selection.Font.Name = "Arial" wrdApp.Selection.Font.Size = 11 wrdApp.Selection.Font.Bold = True t = vbTab For y = 1 To j If Len(ContractTYPE(y)) > 3 Then t = vbTab & vbTab End If Next y If Len(ContractTYPE(k)) > 3 Then wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ":" & vbTab & FundName(k) & " - " & Supplier(k) wrdApp.Selection.TypeParagraph Else wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ":" & t & FundName(k) & " - " & Supplier(k) wrdApp.Selection.TypeParagraph End If Next k wrdApp.Selection.TypeParagraph '--------------------------------------------------------------------------- Date wrdApp.Selection.TypeText Text:="Date:" & t & Format(Date, "dd MMMM yyyy") wrdApp.Selection.TypeParagraph '--------------------------------------------------------------------------- Funds and graphs on page For k = 1 To j If FileFolderExists(ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _ & Application.PathSeparator & FundID(k) & " - " & FundName(k) & " - " & Client & ".doc") Then wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _ & Application.PathSeparator & FundID(k) & " - " & FundName(k) & " - " & Client & ".doc", "", False, False, False Else wrdApp.Selection.Style = "Heading 1" wrdApp.Selection.TypeText Text:=ContractTYPE(k) & ": " & FundName(k) wrdApp.Selection.TypeParagraph wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Graphs " & Format(Date, "yyyy-MM-dd") _ & Application.PathSeparator & "___" & FundID(k) & " - " & FundName(k) & ".doc", "", False, False, False End If Next k '--------------------------------------------------------------------------- Coments wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Coments.doc", "", False, False, False '--------------------------------------------------------------------------- Contacts wrdApp.Selection.Style = "Heading 1" wrdApp.Selection.TypeText Text:="Contacts" wrdApp.Selection.TypeParagraph wrdApp.Selection.Style = "No Spacing" wrdApp.Selection.Font.Name = "Arial" wrdApp.Selection.Font.Size = 11 wrdApp.Selection.Font.Bold = False wrdApp.Selection.ParagraphFormat.SpaceAfter = 0 wrdApp.Selection.ParagraphFormat.LineSpacingRule = "Single" wrdApp.Selection.ParagraphFormat.LineSpacing = 0 wrdApp.Selection.TypeText Text:="For further information please contact your Relationship Manager:" '--------------------------------------------------------------------------- Contacts RM k = 1 wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeText Text:=RM(k) wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeText Text:=JobTitle(k) wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph If Len(Phone(k)) > 1 Then wrdApp.Selection.TypeText Text:="T " & Phone(k) wrdApp.Selection.TypeParagraph End If If Len(Mobile(k)) > 1 Then wrdApp.Selection.TypeText Text:="M " & Mobile(k) wrdApp.Selection.TypeParagraph End If wrdApp.Selection.TypeText Text:="E " Dim RngEmail As Word.Range Set RngEmail = .Content RngEmail.Collapse wdCollapseEnd .Hyperlinks.Add Anchor:=RngEmail, Address:="Mailto:%20" & _ Email(k), SubAddress:="", ScreenTip:="", TextToDisplay _ :=Email(k), Target:="": RngEmail.Collapse wdCollapseEnd wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph If Len(TA(k)) > 1 Then wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeText Text:="Trading Assistant contact details:" wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeText Text:=TA(k) wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeText Text:="Trading Assistant" wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph If Len(TA_Phone(k)) > 1 Then wrdApp.Selection.TypeText Text:="T " & TA_Phone(k) wrdApp.Selection.TypeParagraph End If wrdApp.Selection.TypeText Text:="E " Set RngEmail = .Content RngEmail.Collapse wdCollapseEnd .Hyperlinks.Add Anchor:=RngEmail, Address:="Mailto:%20" & _ TA_Email(k), SubAddress:="", ScreenTip:="", TextToDisplay:=TA_Email(k), Target:="" RngEmail.Collapse wdCollapseEnd wrdApp.Selection.TypeParagraph wrdApp.Selection.TypeParagraph End If wrdApp.Selection.TypeText Text:="Address" '---------------------------------------------------------------------------Disclaimer wrdApp.ActiveWindow.ActivePane.View.Type = 3 wrdApp.ActiveWindow.ActivePane.View.SeekView = 10 wrdApp.Selection.InsertParagraphAfter wrdApp.Selection.InsertFile ThisWorkbook.Path & "\Disclaimer.doc", "", False, False, False wrdApp.Selection.InsertAfter "REPORT - " & Client '--------------------------------------------------------------------------- Display only text (not blank space) 'With wrdApp.ActiveWindow.ActivePane.View ' .SeekView = wdSeekMainDocument ' .DisplayPageBoundaries = Not .DisplayPageBoundaries 'End With '--------------------------------------------------------------------------- .SaveAs (MyName & "\Reports as at " & Format(Date, "yyyy-mm-dd") & Application.PathSeparator & Surname(k) & Application.PathSeparator & Client & _ " - Report as at " & Format(Date, "yyyy-MM-dd") & " " & Initials(k) & ".doc") .Content.Clear End With wrdApp.Quit ' close the Word application Set wrdDoc = Nothing Set wrdApp = Nothing .AutoFilterMode = False Next CUniqueClient Range(.Cells(Rows.Count, "A").End(xlUp), .Cells(Rows.Count, "A").End(xlUp).End(xlUp)).Cells.Clear End With Application.StatusBar = False Application.ScreenUpdating = True Application.EnableEvents = True MsgBox "Elapsed Time " & Format(Now() - Speed, "hh:mm:ss") End Sub Public Function FileFolderExists(strFullPath As String) As Boolean On Error GoTo EarlyExit If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True EarlyExit: On Error GoTo 0 End Function

Thank you

Bogdan

That's a lot of objects. I would look at taking the portion of code which sets your Word application object, and remove it from your loop. You only need one application instance really. Not having to go through that will help. You're doing quite a bit with your code, it stands to reason it will take a while. Something I don't understand is where you're setting a Style in Word, but then you go into details on changing the format/paragraph. The point of Style's is to have a pre-formed set of formats/paragraphs you can set all at once. I doubt it'll speed your code up too much, but it might improve things.

I'll have a look at this, but can you tell me what will happen for clients like Time,Vodafone who do not have 4 lines. And what if there are more than 4 lines per client?

Can you attach a few samples for those also.

Thank you for your time spent on my macro
I will put examples for clients with more than 4 lines, but is no difference: macro will add another page with that line (if client have 1 line - report will have 4 pages (first page + report page+Comments page+Contacts page)(2 line means 2*"report page" - total of 5 pages, 5 lines means report of 8 pages )
I will be back soon with examples

regarding styles: "Heading 1" is default style in word
I change styles because I dont want all lines to be Heading 1 and I dont know how to setup a style for further use....but I can digg on forums.
(Except array which is made by Sir Venkat from Mr. Excel forum, everything is made after I read and try/run diferent posts/articles )
Anyhow....
Thank you again