Macro that creates a word document (and then a PDF) very slow

[attikuz]

Hello MrExcel,

I have a macro that essentially exports text in 3 columns into a word document before converting to a PDF. I have had to do this as the text in 1 of the columns is well over 300 characters and can't be done in excel.

Unfortunately when i run the macro it takes about 13 minutes to complete. There are about 40 rows worth of data. Here is my macro:

Sub inbrief()

Dim Cash As Range
Dim Title, activity, Description As String
Dim cell As Range
Dim CurrentRow, LastRow As Integer
Dim wsBrief As Worksheet
Dim wb As Workbook
Dim LR As Long

Application.ScreenUpdating = False

CurrentRow = 2

Set wb = ActiveWorkbook
Set wsBrief = wb.Worksheets("In Briefs")
LR = Cells(Rows.Count, 1).End(xlUp).Row
 
'Clear sheet and filters
wsBrief.Activate
wsBrief.Range("$A$2:$D$1000").AutoFilter Field:=3
wsBrief.Range("A3:D" & LR).ClearContents

'Copy SEDOLs from portfolio tab and bring in in briefs
Sheets("Portfolio").Range("A8:A200").Copy
wsBrief.Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues

'Remove all the blank rows
LastRow = ActiveSheet.UsedRange.Rows.Count
Range("A3:A" & LastRow).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

'Copy the vlookup formulas to import the paras
Range("B1:D1").Copy
Range("B3:D" & LastRow).PasteSpecial xlPasteFormulas

'Filter out any securities that have no data
With wsBrief.Range("$A$2:$H$" & LastRow)
        .AutoFilter Field:=3, Criteria1:="="
        .Offset(1).EntireRow.Delete
        .AutoFilter
End With

With wsBrief.Range("$B$3:$B$" & LastRow)
        .Font.Color = RGB(0, 89, 85)
        .Font.Size = 18
        .Font.Name = "Georgia"
        .WrapText = True
        .RowHeight = 14.25
End With

With wsBrief.Range("$C$3:$D$" & LastRow)
        .Font.Color = vbBlack
        .Font.Size = 11
        .Font.Name = "Georgia"
        .WrapText = True
        .RowHeight = 14.25
End With

Application.ScreenUpdating = True

End Sub

Sub ExcelToWord()

Call inbrief

'This macro exports the data on the "In Briefs" tab into a word document, creates a PDF called InBriefs.PDF, saves it to the user's H:/Brit folder and then closes the word document.
Application.ScreenUpdating = False
Application.StatusBar = "Launching Word ..."

Sheets("In Briefs").Activate

Dim WdApp As New Word.Application, WdDoc As Word.Document

With WdApp
Set WdDoc = .Documents.Add

Application.StatusBar = "Copying data ..."

    With WdDoc
    Sheets("In Briefs").Range("D2").Select
    
    Do Until IsEmpty(ActiveCell.Offset(1, -2).Range("A1"))
    ActiveCell.Offset(1, -2).Range("A1").Select
        Selection.Copy
    Application.Wait Now + (TimeValue("00:00:01"))
    .Range.Characters.Last.Paste
        ActiveCell.Offset(0, 1).Range("A1").Select
        Selection.Copy
    Application.Wait Now + (TimeValue("00:00:01"))
    .Range.Characters.Last.Paste
        ActiveCell.Offset(0, 1).Range("A1").Select
        Selection.Copy
    Application.Wait Now + (TimeValue("00:00:01"))
    .Range.Characters.Last.Paste
    Application.CutCopyMode = False
    Loop
    
    Application.StatusBar = "Finishing up ..."
    .ExportAsFixedFormat OutputFilename:="H:\Brit\InBriefs.pdf", ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
    
    End With

End With

WdApp.Visible = False

Set WdApp = Nothing

Sheets("Dashboard").Select

Application.StatusBar = False
Application.ScreenUpdating = True
    
End Sub

And here is a sample row of the data that is being exported:

Digital 9 Infrastructure plc

Digital 9, or D9 as it is known, is named after Sustainable Development Goal 9: Industry, Innovation and Infrastructure. It is an infrastructure trust that invests in a portfolio of subsea fibre cables, data centres, terrestrial fibre, and wireless networks, including 5G. The fund is managed by Triple Point, an asset manager with experience of over $250bn in digital infrastructure transactions. D9 invests in assets which underpin both the internet and global communications: 98% of the world’s data is carried by fibre cables, but only 60% of the required trans-Atlantic subsea capacity is expected to be in place by 2026. The fund’s flagship asset is a £160m investment in AquaComms, a company which operates 20,000km of modern, operational trans-Atlantic subsea fibre cables. D9 raised £300m from investors via IPO in March 2021.

SOCIAL PERFORMANCE Digital infrastructure is crucial to serve the growing demand for data in an increasingly digital world. Triple Point, the fund’s manager, is a signatory to the PRI and embeds ESG criteria into each stage of its investment process. It is applying to become a certified B Corporation, which is awarded to companies meeting the highest standards of verified social and environmental performance, transparency and accountability. Triple Point is also a member of the Sustainable Digital Infrastructure Alliance (SDIA), an independent alliance of stakeholders in the digital sector who have committed to executing a ‘Roadmap to a Sustainable Digital Economy’ by 2030. In assessing investment in an asset, the manager seeks assurance of good customer and stakeholder relations, including management of land rights and social inclusion through access to the asset. It also examines data security, client data protection and associated risks. Strong management and reporting of health and safety (during and after build) is also expected, as well as good labour management including staff wellbeing, good diversity and inclusion practices, appropriate training, and presence of fair pay, including assurance on the absence of modern slavery. ENVIRONMENTAL PERFORMANCE The manager has robust plans in place for decarbonisation of digital infrastructure energy use and is targeting net zero emissions from its data centres, which form part of a sector that represents one of the world’s fastest growing consumers of energy. Investee companies are assessed using both SASB and SDIA frameworks, as well as being assessed against the TCFD framework. It also considers the biodiversity and habitat implications of its assets, as well as looking at levels of waste generated, avoided and disposed of, and the approach to raw material sourcing and supply chain sustainability. While expecting a minimum level of ESG performance, the fund also works with companies to improve performance through engagement.

Any help to optimise the macro and speed it up (ideally to under 5 mins) would be greatly appreciated.

Thanks!

 

[Anthony47]

Try this version in place of your Sub ExcelToWord:

Sub ExcelToWord22()
Debug.Print "START >>>"
myTim = Timer
Call inbrief
Debug.Print "A", Format(Timer - myTim, "; 0#; "); ""
'This macro exports the data on the "In Briefs" tab into a word document, creates a PDF called InBriefs.PDF, saves it to the user's H:/Brit folder and then closes the word document.
Application.ScreenUpdating = False
Application.StatusBar = "Launching Word ..."

Sheets("In Briefs").Activate

Dim WdApp As New Word.Application, WdDoc As Word.document
Dim StrStr As String
'
With WdApp
    Set WdDoc = .Documents.Add
    Debug.Print "B", Format(Timer - myTim, "0.00")
    Application.StatusBar = "Copying data ..."
    WdApp.Visible = True
    With WdDoc
        Sheets("In Briefs").Range("D2").Select
        Do Until IsEmpty(ActiveCell.Offset(1, -2).Range("A1"))
            StrStr = Application.WorksheetFunction.TextJoin(vbCrLf, True, Selection.Offset(1, -2).Resize(1, 3))
            .Content.InsertAfter Text:=StrStr & vbCrLf
            Selection.Offset(1, 0).Select
            DoEvents
        Loop
        Debug.Print "C", Format(Timer - myTim, "0.00")
        Application.StatusBar = "Finishing up ..."
        .ExportAsFixedFormat OutputFilename:="H:\Brit\InBriefs.pdf", ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
    End With
End With
WdApp.Visible = False
Set WdApp = Nothing
Sheets("Dashboard").Select

Application.StatusBar = False
Application.ScreenUpdating = True
Debug.Print "D", Format(Timer - myTim, "0.00")
End Sub

If the timing is still poor then open the "Immediate window" of your vba (typing Contr-g should do the jow; or Menu /View /Immediate window), copy the information printed there (from START>>> to the end) and paste it into your next message

Bye

 

[attikuz]

Thanks for this. It was done in 3 minutes HOWEVER all the formatting has been removed.

Currently all the data in Col B is Georgia, 18 in a specific green. The data in C and D are Georgia, 11 black but the new code doesn't export it like this, is it possible to add formatting?

 

[Anthony47]

Which formats would you like to keep on the word document? This requirement would probably expand the run time to your original timing, but we shall try...

 

[attikuz]

Col B (the header - so in the example above Digital 9 Infrastructure plc) needs to be Georgia, 18 RGB(0,89,85). The other two columns need to be Georgia 11, RGB(0,0,0).

Format is as per attached screenshot.

Do you know if it is possible to add a header to each page of the word doc and then a fixed glossary page at the end?

 

[Anthony47]

Try this new version:

Debug.Print "START3 >>>"
myTim = Timer
Call InBrief
Debug.Print "A", Format(Timer - myTim, "; 0#; "); ""
'This macro exports the data on the "In Briefs" tab into a word document, creates a PDF called InBriefs.PDF, saves it to the user's H:/Brit folder and then closes the word document.
Application.ScreenUpdating = False
Application.StatusBar = "Launching Word ..."

Sheets("In Briefs").Activate

Dim WdApp As New Word.Application, WdDoc As Word.document
Dim StrStr As String
'
With WdApp
    Set WdDoc = .Documents.Add
    Debug.Print "B", Format(Timer - myTim, "0.00")
    Application.StatusBar = "Copying data ..."
    WdApp.Visible = False ' True
    With WdDoc
        Sheets("In Briefs").Range("D2").Select
        For j = 3 To Cells(Rows.Count, "B").End(xlUp).Row
            For I = 2 To 4                                  'Columns B to D
                StrStr = vbCrLf & Cells(j, I)
                .Content.InsertAfter Text:=StrStr
                With .Paragraphs.Last
                    .Range.Font.Name = Cells(j, I).Font.Name
                    .Range.Font.Size = Cells(j, I).Font.Size
                    .Range.Font.Color = Cells(j, I).Font.Color
                End With
                DoEvents
            Next I
        Next j
        Debug.Print "C", Format(Timer - myTim, "0.00")
        Application.StatusBar = "Finishing up ..."
        .ExportAsFixedFormat OutputFilename:="H:\Brit\InBriefs.pdf", ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
    End With
End With
WdApp.Visible = False
Set WdApp = Nothing
Sheets("Dashboard").Select

Application.StatusBar = False
Application.ScreenUpdating = True
Debug.Print "D", Format(Timer - myTim, "0.00")
End Sub

The run time almost doubled, in my tests...

As far as a page header, I suggest that you create an empty document that include the preferred header; then rather than using Set WdDoc = .Documents.Add you use

    Set WdDoc = .Documents.Open "YourStartingFile"

Similarly, you can prepare a Glossary Document and then append it at the end of the created document using the Selection.InsertFile method (Selection.InsertFile method (Word)) just before exporting it to pdf

Bye

 

[attikuz]

Hello! thanks for all your help so far. I think we are almost there but for some reason. when i tested it with about 70 rows, for some reason some of the data in cols C & D are coming out in the format of Col B - this is why i added those "wait" lines in my original code. Any ideas?

 

[Anthony47]

Its not a matter of delay (with my macro), it's a problem with my algorythm: I assumed that each cell will be a paragraph, but I see that you expect to set (for sure in column C) text that will be splitted on several paragraphs, tricking my "format last paragraph" approach.
This "penultimate version" should avoid that problem:

Sub ExcelToWord33B()
Debug.Print "START >>>"
myTim = Timer
Call InBrief
Debug.Print "A", Format(Timer - myTim, "; 0#; "); ""
'This macro exports the data on the "In Briefs" tab into a word document, creates a PDF called InBriefs.PDF, saves it to the user's H:/Brit folder and then closes the word document.
Application.ScreenUpdating = False
Application.StatusBar = "Launching Word ..."

Sheets("In Briefs").Activate

Dim WdApp As New Word.Application, WdDoc As Word.document
Dim StrStr As String
Dim FArr(2 To 4, 1 To 3)
'
With WdApp
    Set WdDoc = .Documents.Add
    Debug.Print "B", Format(Timer - myTim, "0.00")
    Application.StatusBar = "Copying data ..."
    WdApp.Visible = True
    With WdDoc
        Sheets("In Briefs").Range("D2").Select
        For j = 3 To Cells(Rows.Count, "B").End(xlUp).Row
            For I = 2 To 4                                  'Columns B to D
                If j < 4 Then
                    FArr(I, 1) = Cells(j, I).Font.Name
                    FArr(I, 2) = Cells(j, I).Font.Size
                    FArr(I, 3) = Cells(j, I).Font.Color
                End If
                StrStr = vbCrLf & Replace(Cells(j, I), Chr(10), Chr(11), , , vbTextCompare)
                .Content.InsertAfter Text:=StrStr
                With .Paragraphs.Last
                    .Range.Font.Name = FArr(I, 1)
                    .Range.Font.Size = FArr(I, 2)
                    .Range.Font.Color = FArr(I, 3)
                End With
                DoEvents
            Next I
        Next j
        Debug.Print "C", Format(Timer - myTim, "0.00")
        Application.StatusBar = "Finishing up ..."
        .ExportAsFixedFormat OutputFilename:="D:\DDocs\InBriefs.pdf", ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
    End With
End With
WdApp.Visible = False
Set WdApp = Nothing
Sheets("Dashboard").Select

Application.StatusBar = False
Application.ScreenUpdating = True
Debug.Print "D", Format(Timer - myTim, "0.00")
End Sub

Also, this version read the format only on the first line, and apply such formats to all the lines; is this correct with your datas?

 

[attikuz]

Hi Anthony,

I'm still having issues. The data in the spreadsheet looks like this:

So column B is in one format, then Col C and D in another.

I want it to appear like the screenshot in post #5. Currently, sometimes col C is coming out in the same format as Col B (but not consistently):

 

[Anthony47]

This is the latest version I can think about with the current information:

Sub ExcelToWord44()
Debug.Print "START >>>"
myTim = Timer
Call InBrief
Debug.Print "A", Format(Timer - myTim, "; 0#; "); ""
'This macro exports the data on the "In Briefs" tab into a word document, creates a PDF called InBriefs.PDF, saves it to the user's H:/Brit folder and then closes the word document.
Application.ScreenUpdating = False
Application.StatusBar = "Launching Word ..."

Sheets("In Briefs").Activate

Dim WdApp As New Word.Application, WdDoc As Word.document
Dim StrStr As String
Dim FArr(2 To 4, 1 To 3)
'
For I = 2 To 4             'Get the formats
    FArr(I, 1) = Cells(3, I).Font.Name
    FArr(I, 2) = Cells(3, I).Font.Size
    FArr(I, 3) = Cells(3, I).Font.Color
Next I
'
With WdApp
    Set WdDoc = .Documents.Add
    Debug.Print "B", Format(Timer - myTim, "0.00")
    Application.StatusBar = "Copying data ..."
    WdApp.Visible = True
    With WdDoc
        Sheets("In Briefs").Range("D2").Select
        .Content.InsertAfter Text:=vbCrLf
        For j = 3 To Cells(Rows.Count, "B").End(xlUp).Row
            For I = 2 To 4                                  'Columns B to D
            
                With .Paragraphs.Last
                    .Range.Font.Name = FArr(I, 1)
                    .Range.Font.Size = FArr(I, 2)
                    .Range.Font.Color = FArr(I, 3)
                End With
                StrStr = Cells(j, I) & vbCrLf
                .Content.InsertAfter Text:=StrStr
                DoEvents
            Next I
        Next j
        Debug.Print "C", Format(Timer - myTim, "0.00")
        Application.StatusBar = "Finishing up ..."
        .ExportAsFixedFormat OutputFilename:="D:\DDocs\InBriefs.pdf", ExportFormat:=wdExportFormatPDF, OpenAfterExport:=True
    End With
End With
WdApp.Visible = False
Set WdApp = Nothing
Sheets("Dashboard").Select

Application.StatusBar = False
Application.ScreenUpdating = True
Debug.Print "D", Format(Timer - myTim, "0.00")
End Sub

If this one still doesn't perform correctly I'll ask for a demo file, as I think the content of the cells can determine the result

Bye