Extremely Slow Code

G

Gil

Any advice for improving the speed of this code? It runs extremely
slow when the word documents start to contain a lot of information,
over ten minutes for a 190page document....

Thanks,
Gil


'
***************************************************************************
'
*
*
' * Input: EndDate as the pay periods end
date. *
' * Process: Creates the word reports for each
department. *
' * Precondition:
NONE *
' * Postcondition:
NONE *
' * Output
NONE *
'
*
*
'
***************************************************************************


Public Function Create_Word_Rate_Report(ByVal EndDate As String) As
Integer
Dim wdApp As Object
'Dim wdApp As Word.Application
Dim myDoc As Object
Dim pp As Object
Dim vAnswer, index, indextwo, indexthree, I As Integer
Dim Myrange As Range
Dim objWordTable As Object
Dim nfso As Object
Dim myFileName, image_path, Current_Section, destination_path As
String



Set nfso = CreateObject("Scripting.FileSystemObject")
vAnswer = MsgBox(Prompt:="Do you want to continue and create the
word reports?" _
, Buttons:=vbYesNo)

If vAnswer <> 6 Then
Create_Word_Rate_Report = 3
MsgBox ("Word report process Aborted! ")
Application.DisplayAlerts = False
Workbooks("ClasTimecard" & EndDate & ".csv").Close
Exit Function
End If
TimeFunction "word_report", 0
Create_Word_Rate_Report = 0
'
***************************************************************************
' * image_path is the path to the uconn logo that is placed in the
word *
' * reports. If this file is missing, it will cause an error when
creating *
' * the word files. Check to make sure this file
exists. *
'
***************************************************************************
image_path = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path) - 19)
& _
"RateReports\Images\Logo.jpg"
' destination_path is the path to save the word reports when they
are created
destination_path = Left(ThisWorkbook.Path, Len(ThisWorkbook.Path)
- 19) & _
"RateReports\" & EndDate & "\"
'destination_path = "C:\clastest\RateReports\" & EndDate & "\"


'
***************************************************************************
' * Create the save folder using the destination_path. If an error
occured, *
' * there was a problem creating the
folder. *
'
***************************************************************************
On Error GoTo Create_Folder_errorHandler
If nfso.FolderExists(destination_path) = False Then
nfso.CreateFolder (destination_path)
End If
'
***************************************************************************
' * Index is used to keep track of which report is being created.
Can also *
' * tell how many reports were
created. *
'
***************************************************************************
index = 0
' Open up word. If an error occured, there was a problem opening
word.
On Error GoTo Open_Word_errorHandler
Set wdApp = CreateObject("Word.Application")
'Set wdApp = New Word.Application
With wdApp
.Visible = False
.WindowState = wdWindowStateMaximize
End With

Set myDoc = wdApp.Documents.Add
Set pp = myDoc.Paragraphs.Add

Set Myrange = Intersect(Sheets("ClasTimeCardRate").UsedRange, _
Sheets("ClasTimeCardRate").Columns("A:A"))
' If the ClasTimeRate sheet is empty, then exit this function
If Myrange Is Nothing Then Exit Function
' Holds the path and the beginning name of the word report to be
saved
myFileName = destination_path & "RateReport" & EndDate
' Current_Section is the section of the employee that report is
being created for.
Current_Section = Myrange.Cells(2, 4)

' If while Create word documents an error occured then goto
Creating_Reports_errorHandler
On Error GoTo Creating_Reports_errorHandler
' Create Report Process...

For I = 2 To Myrange.Rows.Count
index = index + 1
If Current_Section <> Myrange.Cells(I, 4) Then
Application.DisplayAlerts = False
myDoc.SaveAs Filename:=myFileName & "_" & Current_Section
& ".doc", _
FileFormat:=wdFormatDocument
myDoc.Close SaveChanges:=False
Current_Section = Myrange.Cells(I, 4)
index = 1
Set myDoc = wdApp.Documents.Add
Set pp = myDoc.Paragraphs.Add
ElseIf index <> 1 Then
pp.Range.InsertBreak Type:=wdPageBreak
pp.Range.InsertAfter (vbCrLf)
End If

With pp
If index = 1 Then
.Range.Text = " " & vbCrLf
Else
.Range.InsertAfter (" ")
End If
.Range.InlineShapes.AddPicture _
Filename:=image_path
.Alignment = wdAlignParagraphLeft
.Range.InsertAfter (vbCrLf & vbCrLf & "Payroll Time Card
Report")
.Range.Underline = wdUnderlineSingle
.Range.Bold = True
.Alignment = wdAlignParagraphCenter
.Range.InsertAfter (vbCrLf)

.Range.Paragraphs.Alignment = wdAlignParagraphCenter

' Create Table 1 Process...
Set objWordTable = .Range.Tables.Add(.Range, 2, 2)
objWordTable.Rows.Alignment = wdAlignRowCenter
objWordTable.Borders.Enable = False

objWordTable.Cell(1, 1).Range.Text = "Pay Period Ending: "
objWordTable.Cell(1, 1).Range.ParagraphFormat. _
Alignment = wdAlignParagraphRight
objWordTable.Cell(1, 1).Range.Bold = False
objWordTable.Cell(1, 1).Range.Underline = wdUnderlineNone
objWordTable.Cell(1, 1).Range.Italic = True
objWordTable.Cell(1, 2).Range.Text = Myrange.Cells(I, 5)
objWordTable.Cell(1, 2).Range.Bold = False
objWordTable.Cell(1, 2).Range.Italic = True
objWordTable.Cell(1, 2).Range.Underline = wdUnderlineNone
objWordTable.Cell(2, 1).Range.Text = "Check Dated: "
objWordTable.Cell(2, 1).Range.ParagraphFormat. _
Alignment = wdAlignParagraphRight
objWordTable.Cell(2, 1).Range.Bold = False
objWordTable.Cell(2, 1).Range.Underline = wdUnderlineNone
objWordTable.Cell(2, 1).Range.Italic = True
objWordTable.Cell(2, 2).Range.Text = Myrange.Cells(I, 5) +
15
objWordTable.Cell(2, 2).Range.Bold = False
objWordTable.Cell(2, 2).Range.Italic = True
objWordTable.Cell(2, 2).Range.Underline = wdUnderlineNone
objWordTable.Columns.AutoFit
' End Create Table 1 Process...

.Range.Bold = False
.Range.Italic = True
.Range.Underline = wdUnderlineNone
.Range.InsertAfter (vbCrLf & vbCrLf)

' Create Table 2 Process...
Set objWordTable = .Range.Tables.Add(.Range, 2, 4)
objWordTable.Borders.Enable = False

For indextwo = 1 To 4
For indexthree = 1 To 3
objWordTable.Cell(indexthree,
indextwo).Range.ParagraphFormat. _
Alignment = wdAlignParagraphLeft
If indextwo = 1 And indexthree = 1 Then
objWordTable.Cell(1, indextwo).Range.Text =
"Employee Name: "
ElseIf indextwo = 2 And indexthree = 1 Then
objWordTable.Cell(1, indextwo).Range.Text =
Myrange.Cells(I, 2)
ElseIf indextwo = 3 And indexthree = 1 Then
objWordTable.Cell(1, indextwo).Range.Text =
"Section: "
ElseIf indextwo = 4 And indexthree = 1 Then
objWordTable.Cell(1, indextwo).Range.Text =
Myrange.Cells(I, 4)
ElseIf indextwo = 1 And indexthree = 2 Then
objWordTable.Cell(2, indextwo).Range.Text =
"Trankey: "
ElseIf indextwo = 2 And indexthree = 2 Then
objWordTable.Cell(2, 2).Range.Text =
Myrange.Cells(I, 1)
ElseIf indextwo = 3 And indexthree = 2 Then
objWordTable.Cell(2, 3).Range.Text = "BU: "
ElseIf indextwo = 4 And indexthree = 2 Then
objWordTable.Cell(2, 4).Range.Text =
Myrange.Cells(I, 3)
End If

If indextwo = 1 Or indextwo = 3 Then
objWordTable.Cell(indexthree,
indextwo).Range.Bold = True
Else
objWordTable.Cell(indexthree,
indextwo).Range.Bold = False
End If
objWordTable.Cell(indexthree,
indextwo).Range.Italic = False

Next indexthree
Next indextwo
objWordTable.Columns(2).Width = 175
objWordTable.Columns(3).Width = 100
objWordTable.Columns(4).AutoFit
' End Create Table 2 Process...

.Range.InsertAfter (vbCrLf & vbCrLf & vbCrLf)

' Create Table 3 Process...
Set objWordTable = .Range.Tables.Add(.Range, 2, 7)
objWordTable.Borders.Enable = False

For indextwo = 1 To 7
For indexthree = 1 To 3
If indextwo = 1 And indexthree = 1 Then
objWordTable.Cell(indexthree,
indextwo).Range.ParagraphFormat. _
Alignment = wdAlignParagraphLeft
Else
objWordTable.Cell(indexthree,
indextwo).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
End If

If indextwo = 1 And indexthree = 1 Then
objWordTable.Cell(1, 1).Range.Text = "Regular
Hours"
ElseIf indextwo = 2 And indexthree = 1 Then
objWordTable.Cell(1, 2).Range.Text = "ST OT"
ElseIf indextwo = 3 And indexthree = 1 Then
objWordTable.Cell(1, 3).Range.Text = "1.5 HOL"
ElseIf indextwo = 4 And indexthree = 1 Then
objWordTable.Cell(1, 4).Range.Text = "1.5 OT"
ElseIf indextwo = 5 And indexthree = 1 Then
objWordTable.Cell(1, 5).Range.Text = "Regular
SD"
ElseIf indextwo = 6 And indexthree = 1 Then
objWordTable.Cell(1, 6).Range.Text = "OT SD"
ElseIf indextwo = 7 And indexthree = 1 Then
objWordTable.Cell(1, 7).Range.Text = "WE SD"
ElseIf indextwo = 1 And indexthree = 2 Then
objWordTable.Cell(2, 1).Range.Text =
Myrange.Cells(I, 6)
ElseIf indextwo = 2 And indexthree = 2 Then
objWordTable.Cell(2, 2).Range.Text =
Myrange.Cells(I, 7)
ElseIf indextwo = 3 And indexthree = 2 Then
objWordTable.Cell(2, 3).Range.Text =
Myrange.Cells(I, 17)
ElseIf indextwo = 4 And indexthree = 2 Then
objWordTable.Cell(2, 4).Range.Text =
Myrange.Cells(I, 8)
ElseIf indextwo = 5 And indexthree = 2 Then
objWordTable.Cell(2, 5).Range.Text =
Myrange.Cells(I, 9)
ElseIf indextwo = 6 And indexthree = 2 Then
objWordTable.Cell(2, 6).Range.Text =
Myrange.Cells(I, 10)
ElseIf indextwo = 7 And indexthree = 2 Then
objWordTable.Cell(2, 7).Range.Text =
Myrange.Cells(I, 11)
End If

If indexthree = 1 Then
objWordTable.Cell(indexthree,
indextwo).Shading. _
ForegroundPatternColor = wdColorGray10
objWordTable.Cell(indexthree,
indextwo).Range.Bold = True
Else
objWordTable.Cell(indexthree,
indextwo).Range.Bold = False
End If

objWordTable.Cell(indexthree,
indextwo).Range.Italic = False
Next indexthree
Next indextwo
objWordTable.Columns(1).Width = 100
' End Create Table 3 Process...

.Range.InsertAfter (vbCrLf)

' Create Table 4 Process...
Set objWordTable = .Range.Tables.Add(.Range, 2, 5)
objWordTable.Borders.Enable = False

For indextwo = 1 To 5
For indexthree = 1 To 3
If indextwo = 1 And indexthree = 1 Then
objWordTable.Cell(indexthree,
indextwo).Range.ParagraphFormat. _
Alignment = wdAlignParagraphLeft
ElseIf ((indextwo <> 1) And (indexthree <> 2))
Then
objWordTable.Cell(indexthree,
indextwo).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
End If

If indextwo = 2 And indexthree = 1 Then
objWordTable.Cell(1, 2).Range.Text = "Sick"
ElseIf indextwo = 3 And indexthree = 1 Then
objWordTable.Cell(1, 3).Range.Text =
"Vacation"
ElseIf indextwo = 4 And indexthree = 1 Then
objWordTable.Cell(1, 4).Range.Text = "H"
ElseIf indextwo = 5 And indexthree = 1 Then
objWordTable.Cell(1, 5).Range.Text = "PL"
ElseIf indextwo = 1 And indexthree = 2 Then
objWordTable.Cell(2, 1).Range.ParagraphFormat.
_
Alignment = wdAlignParagraphLeft
objWordTable.Cell(2, 1).Range.Text = "Ending
Balance: "
objWordTable.Cell(2, 1).Range.Bold = True
ElseIf indextwo = 2 And indexthree = 2 Then
objWordTable.Cell(2, 2).Range.Text =
Myrange.Cells(I, 13)
ElseIf indextwo = 3 And indexthree = 2 Then
objWordTable.Cell(2, 3).Range.Text =
Myrange.Cells(I, 14)
ElseIf indextwo = 4 And indexthree = 2 Then
objWordTable.Cell(2, 4).Range.Text =
Myrange.Cells(I, 15)
ElseIf indextwo = 5 And indexthree = 2 Then
objWordTable.Cell(2, 5).Range.Text =
Myrange.Cells(I, 16)
End If

If ((indexthree = 1) And (indextwo <> 1)) Then
objWordTable.Cell(indexthree,
indextwo).Shading. _
ForegroundPatternColor = wdColorGray10
objWordTable.Cell(indexthree,
indextwo).Range.Bold = True
ElseIf ((indextwo <> 1) And (indexthree <> 2))
Then
objWordTable.Cell(indexthree,
indextwo).Range.Bold = False
End If

objWordTable.Cell(indexthree,
indextwo).Range.Italic = False
Next indexthree
Next indextwo
objWordTable.Columns(1).Width = 100
' End Create Table 4 Process...

.Range.InsertAfter (vbCrLf & vbCrLf)

' Begin Create Table 5 Process...
Set objWordTable = .Range.Tables.Add(.Range, 1, 2)
objWordTable.Rows.Alignment = wdAlignRowLeft
objWordTable.Borders.Enable = False

objWordTable.Cell(1, 1).Range.Text = "Payroll Rate:"
objWordTable.Cell(1, 1).Range.ParagraphFormat. _
Alignment = wdAlignParagraphLeft
objWordTable.Cell(1, 1).Range.Bold = True
objWordTable.Cell(1, 1).Range.Italic = False
objWordTable.Cell(1, 2).Range.Text = Myrange.Cells(I, 12)
objWordTable.Cell(1, 2).Range.ParagraphFormat. _
Alignment = wdAlignParagraphLeft
objWordTable.Cell(1, 2).Range.Bold = False
objWordTable.Cell(1, 2).Range.Italic = False
objWordTable.Columns.AutoFit
' End Create Table 5 Process...


If Myrange.Cells(I, 18).Value = "Y" Then
.Range.InsertAfter (vbCrLf & vbCrLf & vbCrLf)
'Begin Table 6 create table process
Set objWordTable = .Range.Tables.Add(.Range, 2, 4)
objWordTable.Rows.Alignment = wdAlignRowLeft
objWordTable.Borders.Enable = False

objWordTable.Cell(1, 1).Range.Text = "OverPayment
Amount"
objWordTable.Cell(1, 1).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(1, 1).Shading. _
ForegroundPatternColor = wdColorGray10
objWordTable.Cell(1, 1).Range.Bold = True
objWordTable.Cell(1, 1).Range.Italic = False
objWordTable.Cell(2, 1).Range.Text = Myrange.Cells(I,
19).Text
objWordTable.Cell(2, 1).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(2, 1).Range.Bold = False
objWordTable.Cell(2, 1).Range.Italic = False

objWordTable.Cell(1, 2).Range.Text = "Previously
Collected"
objWordTable.Cell(1, 2).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(1, 2).Shading. _
ForegroundPatternColor = wdColorGray10
objWordTable.Cell(1, 2).Range.Bold = True
objWordTable.Cell(1, 2).Range.Italic = False
objWordTable.Cell(2, 2).Range.Text = Myrange.Cells(I,
20).Text
objWordTable.Cell(2, 2).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(2, 2).Range.Bold = False
objWordTable.Cell(2, 2).Range.Italic = False

objWordTable.Cell(1, 3).Range.Text = "Current Amount"
objWordTable.Cell(1, 3).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(1, 3).Shading. _
ForegroundPatternColor = wdColorGray10
objWordTable.Cell(1, 3).Range.Bold = True
objWordTable.Cell(1, 3).Range.Italic = False
objWordTable.Cell(2, 3).Range.Text = Myrange.Cells(I,
21).Text
objWordTable.Cell(2, 3).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(2, 3).Range.Bold = False
objWordTable.Cell(2, 3).Range.Italic = False

objWordTable.Cell(1, 4).Range.Text = "Remaining
Balance Due"
objWordTable.Cell(1, 4).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(1, 4).Shading. _
ForegroundPatternColor = wdColorGray10
objWordTable.Cell(1, 4).Range.Bold = True
objWordTable.Cell(1, 4).Range.Italic = False
objWordTable.Cell(2, 4).Range.Text = Myrange.Cells(I,
22).Text
objWordTable.Cell(2, 4).Range.ParagraphFormat. _
Alignment = wdAlignParagraphCenter
objWordTable.Cell(2, 4).Range.Bold = False
objWordTable.Cell(2, 4).Range.Italic = False




objWordTable.Columns.AutoFit

End If

End With
Next I
' End Create Report Process...
TimeFunction "word_report", 1
Application.DisplayAlerts = False
myDoc.SaveAs Filename:=myFileName & "_" & Current_Section & ".doc"
myDoc.Close SaveChanges:=False
MsgBox ("The word rate reports were created.")
Application.DisplayAlerts = False
wdApp.Quit
Set wdApp = Nothing
Set myDoc = Nothing
Set Myrange = Nothing
Create_Word_Rate_Report = 1

' Exits the function if an error occured
Exit_Create_Word_Rate_Report:
On Error GoTo 0
Exit Function

' This is executed if there was an error opening word.
Open_Word_errorHandler:
Application.DisplayAlerts = False
wdApp.Quit
Set wdApp = Nothing
Set myDoc = Nothing
Set Myrange = Nothing
MsgBox ("An Error occured while trying to open word! " & _
"Aborting creation of word reports")
Resume Exit_Create_Word_Rate_Report

' This is executed if there was an error creating a the save folder.
Create_Folder_errorHandler:
MsgBox ("An Error occured creating destination folder! " & _
"Aborting creation of word reports.")
Resume Exit_Create_Word_Rate_Report

' This is executed if there was an error creating the word reports.
Creating_Reports_errorHandler:
Application.DisplayAlerts = False
wdApp.Quit
Set wdApp = Nothing
Set myDoc = Nothing
Set Myrange = Nothing
MsgBox ("An Error occured while trying to create the word reports!
" & _
"Aborting creation of word reports")
Resume Exit_Create_Word_Rate_Report
End Function
 
G

Gary Keramidas

you can try this at the beginning of your code:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

and this at the end:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
 
G

George Nicholson

I would use a lot more With..End Withs if performance is an issue.

Then I might try to see if there are specific part that are especially slow
with msgboxes or other benchmarking, and then focus on those sections.

HTH,
 
P

par_60056

you can try this at the beginning of your code:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

and this at the end:

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

--

Gary





















...

read more »

I would guess (from recent experience) that the problem is Word is
repaginating frequently which is a slow process.

Is there a way to tell the word app not to recalculate page breaks?

Peter
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top