patternMinor
Copying data from an Excel sheet to Word
Viewed 0 times
excelsheetwordcopyingfromdata
Problem
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
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:=xlFo
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:=xlFo
Solution
Things you could try:
-
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
-
Avoid
with
-
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.-
Avoid
Selecting unless mandatory. For instance, replaceActiveSheet.Columns("C").Select
ActiveSheet.Pastewith
ActiveSheet.Columns("C").PasteSpecialCode Snippets
ActiveSheet.Columns("C").Select
ActiveSheet.PasteActiveSheet.Columns("C").PasteSpecialContext
StackExchange Code Review Q#95437, answer score: 6
Revisions (0)
No revisions yet.