Copying data from an Excel sheet to Word

Question

This code copies a specific range and a chart from an Excel sheet to Word. This code works fine but it is very slow. I have used delays(Wait) to work properly while dealing with clipboard copy-paste. If I don't use delays as error occurs.

This program copies 140 Excel-ranges and 140 charts, so it takes a lot of time. Any suggestions to make the program execute faster?

Sub ExcelToWord()
    Dim fileName, Pathname As String
    Dim WB As Workbook
    Dim mychart As ChartObject
    Pathname = "c:\Charts\"
    vArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
    For Each vFile In vArr
        fileName = Dir(Pathname & vFile & "\" & "*.xlsx")
        Dim WdObj As Object
        Set WdObj = CreateObject("Word.Application")
        WdObj.Documents.Add
        'Loop for all files begins
        Do While fileName <> ""
            Set WB = Workbooks.Open(Pathname & vFile & "\" & fileName)
            ActiveSheet.Columns("C:C").Select
            Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Dim rLastCell As Range
            Dim ColLtr As String
            Set rLastCell = ActiveSheet.Cells.Find(What:="*", After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, Lookat:= _
            xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
            ColLtr = Replace(Cells(1, rLastCell.Column).Address(True, False), "$1", "")
            ActiveSheet.Columns(ColLtr).Copy
            ActiveSheet.Columns("C").Select
            ActiveSheet.Paste
            Application.CutCopyMode = False
            Dim lastrow As Long, lastcol As Long
            Dim rngTemp As Range
            With ActiveSheet
                If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                    lastrow = .Cells.Find(What:="*", _
                                          After:=.Range("A1"), _
                                          Lookat:=xlPart, _
                                          LookIn:=xlFormulas, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=xlPrevious, _
                                          MatchCase:=False).Row
                    lastcol = 3
                Else
                    lastrow = 1: lastcol = 1
                End If
                Set rngTemp = .Range("A1:" & Split(.Cells(, lastcol).Address, "$")(1) & lastrow)
                Set mychart = ActiveSheet.ChartObjects(1)
            End With
            WdObj.Visible = True
            WdObj.Activate
            rngTemp.Select
            Application.Wait (Now + TimeValue("0:00:01"))
            Selection.Copy
            DoEvents
            Application.Wait (Now + TimeValue("0:00:01"))
            WdObj.Selection.PasteSpecial
            Application.CutCopyMode = False
            mychart.Select
            Application.Wait (Now + TimeValue("0:00:01"))
            Selection.Copy
            DoEvents
            Application.Wait (Now + TimeValue("0:00:01"))
            WdObj.Selection.PasteSpecial
            Application.CutCopyMode = False
            Const wdPageBreak = 7
            Application.Wait (Now + TimeValue("0:00:01"))
            WdObj.Selection.InsertBreak (wdPageBreak)
            Application.Wait (Now + TimeValue("0:00:01"))
            Application.CutCopyMode = False
            WB.Close SaveChanges:=False
            fileName = Dir()
        Loop
        Dim fname As String
        fname = "Converted and Combined.docx"
        Application.CutCopyMode = False
        With WdObj
            .ChangeFileOpenDirectory "C:\Charts\" & vFile & "\"
            .ActiveDocument.SaveAs fileName:=fname
        End With
        With WdObj
            .ActiveDocument.Close
            .Quit
        End With
        Set WdObj = Nothing
    Next
End Sub

Answer 1

Things you could try:

1. Set shorter wait times. This shows you how. This is likely the main source of delay. You can assess if this is true by timing the total time, and calculating the time taken with each vfile.

2. Avoid Selecting unless mandatory. For instance, replace

   ActiveSheet.Columns("C").Select
   ActiveSheet.Paste
   

   with

   ActiveSheet.Columns("C").PasteSpecial
   

Answer 2

One thing that takes a lot of time in VBA code is switching windows. I usually disable graphical updates with

Application.Screenupdating = false

at the top of my function, then

Application.Screenupdating = true

at the exit(s).

More details on this, here

Answer 3

The following is a start at an answer to speed things up.

Basically, I have begun to replace all instances in which you individually .select and or reference the same object over and over(esp. Activesheet)

Take a look and compare to your version. Please note that I did not have a chance to run this:

Sub ExcelToWord()
    Dim fileName, Pathname As String
    Dim WB As Workbook
    Dim mychart As ChartObject
    Dim vArr
    Dim vFile
    Pathname = "c:\Charts\"
    vArr = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J")
    For Each vFile In vArr
        fileName = Dir(Pathname & vFile & "\" & "*.xlsx")
        Dim WdObj As Object
        Set WdObj = CreateObject("Word.Application")
        WdObj.Documents.Add
        'Loop for all files begins
        Do While fileName <> ""
            Set WB = Workbooks.Open(Pathname & vFile & "\" & fileName)
            Dim wks As Excel.Worksheet
            Set wks = WB.Worksheets(1)
            wks.Columns("C:C").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
            Dim rLastCell As Range
            Dim ColLtr As String
            Set rLastCell = wks.Cells.Find(What:="*", After:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, Lookat:= _
            xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
            ColLtr = Replace(Cells(1, rLastCell.Column).Address(True, False), "$1", "")
            wks.Columns(ColLtr).Copy wks.Columns("C")
            Application.CutCopyMode = False
            Dim lastrow As Long, lastcol As Long
            Dim rngTemp As Range
            With wks
                If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
                    lastrow = .Cells.Find(What:="*", _
                                          After:=.Range("A1"), _
                                          Lookat:=xlPart, _
                                          LookIn:=xlFormulas, _
                                          SearchOrder:=xlByRows, _
                                          SearchDirection:=xlPrevious, _
                                          MatchCase:=False).Row
                    lastcol = 3
                Else
                    lastrow = 1: lastcol = 1
                End If
                Set rngTemp = .Range("A1:" & Split(.Cells(, lastcol).Address, "$")(1) & lastrow)
                Set mychart = wks.ChartObjects(1)
            End With
            WdObj.Visible = True
            WdObj.Activate
            rngTemp.Select
            Application.Wait (Now + TimeValue("0:00:01"))
            Selection.Copy
            DoEvents
            Application.Wait (Now + TimeValue("0:00:01"))
            WdObj.Selection.PasteSpecial
            Application.CutCopyMode = False
            mychart.Select
            Application.Wait (Now + TimeValue("0:00:01"))
            Selection.Copy
            DoEvents
            Application.Wait (Now + TimeValue("0:00:01"))
            WdObj.Selection.PasteSpecial
            Application.CutCopyMode = False
            Const wdPageBreak = 7
            Application.Wait (Now + TimeValue("0:00:01"))
            WdObj.Selection.InsertBreak (wdPageBreak)
            Application.Wait (Now + TimeValue("0:00:01"))
            Application.CutCopyMode = False
            WB.Close SaveChanges:=False
            fileName = Dir()
        Loop
        Dim fname As String
        fname = "Converted and Combined.docx"
        Application.CutCopyMode = False
        With WdObj
            .ChangeFileOpenDirectory "C:\Charts\" & vFile & "\"
            .ActiveDocument.SaveAs fileName:=fname
        End With
        With WdObj
            .ActiveDocument.Close
            .Quit
        End With
        Set WdObj = Nothing
    Next
End Sub

Answer 4

Those waits will kill you. A second doesn't seem like much, until you stack a lot of them together. I don't think you need to set CutCopyMode to False until the very end, either.

What I would try is something like the following. Instead of this, which has two built-in wait periods:

rngTemp.Select
Application.Wait (Now + TimeValue("0:00:01"))
Selection.Copy
DoEvents
Application.Wait (Now + TimeValue("0:00:01"))
WdObj.Selection.PasteSpecial

I would use a loop to repeat the attempted paste until it has no error, something like this:

Do
    On Error Resume Next
    rngTemp.Copy
    DoEvents
    WdObj.Selection.PasteSpecial
    If Err.Number = 0 Then
        On Error Goto 0
        Exit Do
    End If
Loop

In fact, it seems to me that there isn't so much a problem with the copy as with the paste, so try this first:

rngTemp.Copy
DoEvents
Do
    On Error Resume Next
    WdObj.Selection.PasteSpecial
    If Err.Number = 0 Then
        On Error Goto 0
        Exit Do
    End If
Loop