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

• Mark Fitzgerald: What error do you get and which line is highlighted?

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

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

• Taylor Raine: I would format the last code segment as On Error Resume Next Do ` WdObj.Selection.PasteSpecial` ` If Err.Number = 0 Then: Exit Do` Loop On Error GoTo 0 to reduce the number of calls within the Do..Loop, and to increase readability - though admittedly, that last point is more of a personal preference
• Jon Peltier: I think there was a reason I put the On Error calls inside rather than outside the loop, but I don't recall what it may have been.

Answer 4

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

• brettdj: Upvoted for a comprehensive answer.