Re: How to speed up creation of docs without displaying them.

Tech Tip: Click here to run a free scan for Windows Errors and optimize PC performance

Hi,
So far, this is all I could find on internet to make the writing faster.

Set wdDoc = ThisDocument
Application.Options.CheckSpellingAsYouType = False
Application.Options.CheckGrammarAsYouType = False
Application.ScreenUpdating = False
ActiveWindow.View.Type = wdNormalView
Application.Options.Pagination = False
wdDoc.UndoClear

Regards
JY


<cc900630@xxxxxxxxx> wrote in message
news:1157968339.147722.164220@xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
Hiya - I am using this vba code below to create in excess of 4000
custom word docs based on a template.
The code creates a new doc, fills out lots of tables , saves it to disk
and then closes it within a loop. It works just fine but its taking
about 3 hours to run, is there any way to speed it up. Im sure I was
able to run it in "invisible mode" once before or something but cant
figure that out now . Thx in advance.


Sub BatchRun ()

'On Error Resume Next
Dim arrData, intSite, strQual, strOffice, intRow, strData,
strSourceDoc, arrName, strName, strSite
Dim objConn As Object
Dim objRS As Object
Dim strSelectList, strSQL, intCol
Dim objFSO, objFile, arrLines


' Open the text file and read the contents into an arra
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.openTextFile("c:/batchrun/export.csv")
strData = objFile.ReadAll

arrLines = Split(strData, vbCrLf)

' kill the text file objects
Set objFile = Nothing
Set objFSO = Nothing

' open the database ready for selecting details
Set objConn = CreateObject("ADODB.Connection")
openDB objConn

' loop over the text files rows
For intRow = 0 To UBound(arrLines, 1)


strSourceDoc = ActiveDocument.FullName
Documents.Add strSourceDoc



' Read the qualcode, Site ID and Office Name
arrData = Split(arrLines(intRow), ",")
strQual = arrData(0)
intSite = arrData(1)
strOffice = arrData(2)



strSelectList =
"SiteName,Add1,Add2,TownCity,PostCode,County,Telephone "
strSQL = "SELECT " & strSelectList & " FROM vwSites " & _
"WHERE SiteID=" & intSite

Set objRS = objConn.Execute(strSQL)
If Not objRS.EOF Then


' Write the centre details

' small sitte id in table 3
With ActiveDocument.Tables(3)
.Rows(1).Cells(5).Select
Selection.Text = "Site ID: " & intSite
End With

' other site details in table 1
With ActiveDocument.Tables(1)
.Rows(4).Cells(2).Select
Selection.Text = objRS("SiteName")

.Rows(5).Cells(2).Select
Selection.Text = objRS("Add1")

.Rows(6).Cells(2).Select
Selection.Text = objRS("Add2")

.Rows(7).Cells(2).Select
Selection.Text = objRS("TownCity") & " " &
objRS("PostCode")

.Rows(8).Cells(2).Select
Selection.Text = objRS("County")

.Rows(9).Cells(2).Select
Selection.Text = objRS("Telephone")
End With
End If

strSite = Replace(Left(objRS("SiteName"), 10), " ", "_")



' write the module details / crosstab bit

strSQL = "SELECT QualTitle, QualUnitCode,UnitTitle, Office,
CourseFee, UnitFee,FullName FROM vwQualUnits " & _
"WHERE QualCode='" & strQual & "' ORDER BY
QualUnitCode"

Set objRS = objConn.Execute(strSQL)
If Not objRS.EOF Then



ActiveDocument.Tables(1).Rows(3).Cells(2).Select
Selection.Text = strQual & " " & objRS("QualTitle")

ActiveDocument.Tables(1).Rows(1).Cells(5).Select
Selection.Text = objRS("Office")


intCol = 8 ' start of the unit columns
While Not objRS.EOF

ActiveDocument.Tables(2).Rows(1).Cells(intCol).Select
Selection.Text = objRS("QualUnitCode") & " " &
objRS("UnitTitle")
intCol = intCol + 1
objRS.MoveNext
Wend



objRS.MoveFirst
ActiveDocument.Tables(3).Rows(1).Cells(2).Select
Selection.Text = "@ £" & objRS("CourseFee")

ActiveDocument.Tables(3).Rows(2).Cells(2).Select
Selection.Text = "@ £" & objRS("UnitFee")

arrName = Split(objRS("Fullname"), " ")
strName = Left(arrName(0), 1) & Left(arrName(1), 1)

' name it qual_site_account manger initials and oput in
relevant office folder
ActiveDocument.SaveAs ("c:/batchRun/" & strOffice & "/" &
strQual & "_" & strCentre & "_" & strName & ".doc")
ActiveDocument.Close
End If



Next

' clean up
objRS.Close
Set objRS = Nothing
objConn.Close
Set objConn = Nothing

End Sub


.

Relevant Pages