Results 1 to 4 of 4

Thread: Speed up excel to word VBA

  1. #1
    Junior Member
    Join Date
    May 2012
    Posts
    2
    Rep Power
    0

    Speed up excel to word VBA

    Orange - Report as at 2012-05-15 A A.zipExample 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
    Last edited by bcostin; 05-15-2012 at 02:43 PM. Reason: sample file added

  2. #2
    Junior Member
    Join Date
    May 2012
    Posts
    4
    Rep Power
    0
    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.

  3. #3
    Administrator Excel Fox's Avatar
    Join Date
    Mar 2011
    Posts
    1,402
    Rep Power
    10
    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.
    A dream is not something you see when you are asleep, but something you strive for when you are awake.

    It's usually a bad idea to say that something can't be done.

    The difference between dream and aim, is that one requires soundless sleep to see and the other requires sleepless efforts to achieve

    Join us at Facebook

  4. #4
    Junior Member
    Join Date
    May 2012
    Posts
    2
    Rep Power
    0
    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

Similar Threads

  1. Replies: 7
    Last Post: 08-24-2015, 10:58 PM
  2. Excel Chart into Word VBA
    By dhiraj.ch185 in forum Word Help
    Replies: 3
    Last Post: 12-26-2012, 11:23 AM
  3. Replies: 1
    Last Post: 10-16-2012, 01:53 PM
  4. Speed up Loop VBA
    By PcMax in forum Excel Help
    Replies: 15
    Last Post: 04-09-2012, 04:20 PM
  5. Excel Chart To Word Convertor
    By Excel Fox in forum Download Center
    Replies: 1
    Last Post: 04-04-2011, 06:21 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •