Speed up excel to word VBA

**bcostin** · 05-15-2012, 01:24 PM

Orange - Report as at 2012-05-15 A A.zip Example 2012-05-15.xls

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

**Zack Barresse** · 05-21-2012, 10:43 PM

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.

**Excel Fox** · 05-21-2012, 10:59 PM

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.

**bcostin** · 05-22-2012, 10:49 AM

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