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