Extremely Slow Code

  • Thread starter Thread starter Gil
  • Start date Start date
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
 
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
 
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,
 
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 »
Click to expand...

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
 
Back
Top