my code is too slow, any advice on optimising it?

[indieman]

Hi,

I have the following code but its running very slow. I lost the original code I created years ago so had to create it again. Im not sure of the method I used last time but this time its definitely about twice as slow as it was. any advice on where im going wrong?

The document is splitting a mail-merged document into individual documents where the filenames are defined from a specific ID number field from within each document in the mail merge.

I start by opening the mail-merge document that contains all 2000 letters one after the other, and then run the code below.

any advice is very welcomed.

thanks,

Sub splitMailMerge()
Dim i As Long
With ActiveDocument
Application.ScreenUpdating = False

For i = 1 To .Sections.Count - 1

'copy individual mail merge sections
.Sections.Item(i).Range.Copy

'open template and paste data
Documents.Open "D:\template.doc"
Selection.PasteAndFormat wdPasteDefault

'remove blank last page by finding the last words in the document and then
'deleting the blank page immediately after
ActiveDocument.Select
With Selection.Find
.Text = "Thank you"
.Execute
End With
Selection.MoveRight Unit:=wdCharacter, Count:=2
Selection.Delete Unit:=wdCharacter, Count:=2

'find the text in the document that the individual files will be named after
ActiveDocument.Select
With Selection.Find
.Text = "ID number "
.Execute
End With
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdWord, Count:=1, Extend:=wdExtend

'save individual document
ActiveDocument.SaveAs FileName:="D:\files\" & Selection.Text & ".doc"
ActiveDocument.Close False

'update status bar with progress
Application.ScreenUpdating = True
StatusBar = i & "/" & .Sections.Count
Application.ScreenUpdating = False

Next i

Application.ScreenUpdating = True
End With

End Sub

[macropod]

Hi indieman,

Try the following:
Sub SplitMailMerge()
Application.ScreenUpdating = False
Dim i As Long, j As Long, Str As String, DocMain As Document, DocTmp As Document
'open template
Set DocMain = ActiveDocument
Set DocTmp = Documents.Open(FileName:="D:\template.doc", AddToRecentfiles:=False)
With DocMain
j = .Sections.Count
For i = 1 To j
'copy individual mail merge sections
.Sections(i).Range.Copy
With DocTmp
With .Range
.PasteAndFormat wdPasteDefault
'remove everything after the last text paragraph's break
While Asc(.Characters.Last.Previous) < 32
.Characters.Last.Previous.Delete
Wend
'find the text the output file will be named after
With .Find
.ClearFormatting
.Text = "ID number <*>"
.MatchWildcards = True
.Execute
End With
Str = Trim(.Duplicate.Words.Last)
End With
'save individual document
.SaveAs FileName:="D:\files\" & Str & ".doc", AddToRecentfiles:=False
'clear in preparation for the next document
.Range.Text = vbNullString
End With
'update status bar with progress
StatusBar = i & "/" & j
Next i
DocTmp.Close SaveChanges:=False
End With
Set DocTmp = Nothing: Set DocMain = Nothing
Application.ScreenUpdating = True
End Sub