Chiedo scusa per la mia risposta poco tempestiva, ma a causa di problemi di connessione prima, e si salute dopo non ho potuto rispondere, e per questo vi chiedo nuovamente scusa.
Non ho nessun problema a mostrarvi il codice, che Vi allego. La novità è che ho provato il codice su una macchina diversa, un portatile con un sistema operativo dicerso, Windows 7 4Gb di ram processore core Duo 2.00 GHz, il risultato è che per creare il documento con word 2003 inpiega all'incirca il 27% del tempo impiegato sulla vecchia macchina che ha come sistema operativo Windosx XP e 3Gb di ram Pentium 4 3.2GHz
Ps: il foglio word nasce da un file .dot
e grazie per le eventuali soluzioni al problema.

Private Sub CmdAvvia_Click()
Dim cn As ADODB.Connection
Dim rsAnnUff As ADODB.Recordset
Dim PAGINA As Integer
Dim Riga As Long
Dim docword As Object
Dim indice, indice2, ordine As Integer
Dim Ruolo, Grado As String
Dim CF As String
On Error GoTo errore
Screen.MousePointer = vbHourglass
Set cn = New ADODB.Connection
cn.Open StrCon
Set rsAnnUff = New ADODB.Recordset
rsAnnUff.Open "SELECT * from vw_stampa_annuario_Uff_inf", cn, adOpenForwardOnly, adLockReadOnly
If Not rsAnnUff.EOF Then
Label1.Visible = True
rsAnnUff.MoveFirst
CF = ""
Do While Not rsAnnUff.EOF
If CF <> rsAnnUff!CodiceFiscale Then
indice2 = indice2 + 1
CF = rsAnnUff!CodiceFiscale
End If
rsAnnUff.MoveNext
Loop
rsAnnUff.MoveFirst
CF = rsAnnUff!CodiceFiscale
Grado = rsAnnUff!Grado
Ruolo = rsAnnUff!Ruolo
Else
MsgBox "errore nella selezione vw_stampa_annuario_gen"
Exit Sub
End If
ProgressBar1.Max = indice2
ProgressBar1.Visible = True
Set docword = New Word.Application
docword.Documents.Add (App.Path & "\Modelli Stampe\annuario.dot")
docword.Visible = True
DoEvents
' docword.Visible = False
' DoEvents
rsAnnUff.MoveFirst
PAGINA = 1
Do While Not rsAnnUff.EOF
If PAGINA = 1 Then
ordine = ordine + 1
docword.ActiveWindow.Selection.Font.Name = "times new roman"
docword.ActiveWindow.Selection.Font.Size = 18
docword.ActiveWindow.Selection.Font.Bold = wdToggle
docword.ActiveWindow.Selection.ParagraphFormat.Lin eSpacing = 150
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:="ESERCITO"
docword.ActiveWindow.Selection.Font.Bold = wdToggle
docword.ActiveWindow.Selection.InsertBreak Type:=wdPageBreak
ordine = ordine + 1
docword.ActiveWindow.Selection.InsertBreak Type:=wdPageBreak
PAGINA = 2
End If
If PAGINA = 2 Then
ordine = ordine + 1
docword.ActiveWindow.Selection.Font.Size = 20
docword.ActiveWindow.Selection.Font.Name = "times new roman"
docword.ActiveWindow.Selection.ParagraphFormat.Lin eSpacing = 150
docword.ActiveWindow.Selection.TypeParagraph
docword.ActiveWindow.Selection.ParagraphFormat.Lin eSpacing = 30
docword.ActiveWindow.Selection.Font.Bold = wdToggle
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:=Trim(rsAnnUff!Ruolo)
docword.ActiveWindow.Selection.Font.Bold = wdToggle
docword.ActiveWindow.Selection.InsertBreak Type:=wdPageBreak
ordine = ordine + 1
docword.ActiveWindow.Selection.InsertBreak Type:=wdPageBreak
DoEvents
PAGINA = 3
End If
Riga = 2
' intestazione e creazione tabella
ordine = ordine + 1
DoEvents
docword.ActiveWindow.Selection.Font.Name = "times new roman"
docword.ActiveWindow.Selection.Font.Size = 8
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.ParagraphFormat.Spa ceBefore = 3
docword.ActiveWindow.Selection.ParagraphFormat.Spa ceBeforeAuto = False
docword.ActiveWindow.Selection.ParagraphFormat.Spa ceAfter = 5
docword.ActiveWindow.Selection.ParagraphFormat.Spa ceAfterAuto = False
docword.ActiveWindow.Selection.ParagraphFormat.Lin eSpacing = 12
DoEvents
' scrivo il ruolo
docword.ActiveWindow.Selection.TypeText Text:=Trim(rsAnnUff!Ruolo)
' a capo
docword.ActiveWindow.Selection.TypeParagraph
' scrivoil grado
docword.ActiveWindow.Selection.Font.Bold = wdToggle
docword.ActiveWindow.Selection.TypeText Text:=Trim(rsAnnUff!Grado)
docword.ActiveWindow.Selection.Font.Bold = wdToggle
docword.ActiveWindow.Selection.TypeParagraph
' Bordo superiore doppio
docword.ActiveWindow.Selection.ParagraphFormat.Lin eSpacingRule = wdLineSpaceDouble
With docword.ActiveWindow.Selection.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceExactly
.LineSpacing = 6
End With
docword.ActiveWindow.Selection.Font.Size = 7
'crea la tabella
docword.ActiveWindow.Selection.Tables.Add Range:=docword.ActiveWindow.Selection.Range, NumRows:=51, NumColumns:= _
5, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
DoEvents
docword.ActiveWindow.Selection.Tables(1).Select
docword.ActiveWindow.Selection.Borders(wdBorderHor izontal).LineStyle = wdLineStyleNone
docword.ActiveWindow.Selection.Tables(1).Borders(w dBorderTop).LineStyle = wdLineStyleDouble
docword.ActiveWindow.Selection.Tables(1).Borders(w dBorderBottom).LineStyle = wdLineStyleNone
docword.ActiveWindow.Selection.Tables(1).Borders(w dBorderHorizontal).LineStyle = wdLineStyles
With docword.ActiveWindow.Selection.Tables(1)
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = True
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = True
End With
' INTESTAZIONE della tabella
docword.ActiveWindow.Selection.Font.Size = 8
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:="N.d'ord."
docword.ActiveWindow.Selection.Borders(wdBorderBot tom).LineStyle = wdLineStyleSingle
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:="COGNOME E NOME"
docword.ActiveWindow.Selection.Borders(wdBorderBot tom).LineStyle = wdLineStyleSingle
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:="Data di nascita"
docword.ActiveWindow.Selection.Borders(wdBorderBot tom).LineStyle = wdLineStyleSingle
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:="Data di anzianità in S.P."
docword.ActiveWindow.Selection.Borders(wdBorderBot tom).LineStyle = wdLineStyleSingle
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.TypeText Text:="Data di anzianità di grado"
docword.ActiveWindow.Selection.Borders(wdBorderBot tom).LineStyle = wdLineStyleSingle
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell
docword.ActiveWindow.Selection.Tables(1).Columns(1 ).PreferredWidth = docword.CentimetersToPoints(1)
docword.ActiveWindow.Selection.Tables(1).Columns(2 ).PreferredWidth = docword.CentimetersToPoints(14)
docword.ActiveWindow.Selection.Tables(1).Columns(3 ).PreferredWidth = docword.CentimetersToPoints(2.3)
docword.ActiveWindow.Selection.Tables(1).Columns(4 ).PreferredWidth = docword.CentimetersToPoints(2.3)
docword.ActiveWindow.Selection.Tables(1).Columns(5 ).PreferredWidth = docword.CentimetersToPoints(2.3)
docword.ActiveWindow.Selection.Font.Size = 7
DoEvents
Do While Not rsAnnUff.EOF
' indico sulla progressbar1 lo stato di avanzamento della stampa
indice = indice + 1
indice3 = indice3 + 1
Label1.Caption = " Stampa Annuario Ufficiali in preparazione...." & indice3 & "/" & indice2
ProgressBar1.Value = indice3
DoEvents
' STAMPO DATI ANAGRAFICI
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.Tables(1).Cell(Riga , 1).Range.InsertAfter indice
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell, Count:=1
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphLeft
docword.ActiveWindow.Selection.Tables(1).Cell(Riga , 2).Range.InsertAfter rsAnnUff!Cognome & " " & rsAnnUff!Nome1
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell, Count:=1
docword.ActiveWindow.Selection.ParagraphFormat.Ali gnment = wdAlignParagraphCenter
docword.ActiveWindow.Selection.Tables(1).Cell(Riga , 3).Range.InsertAfter rsAnnUff!DataDiNascita
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell, Count:=1
docword.ActiveWindow.Selection.Tables(1).Cell(Riga , 4).Range.InsertAfter rsAnnUff!DataArruolamento
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell, Count:=1
docword.ActiveWindow.Selection.Tables(1).Cell(Riga , 5).Range.InsertAfter rsAnnUff!DataPromozione
'contatore di una riga della tabella
Riga = Riga + 1
rsAnnUff.MoveNext
docword.ActiveWindow.Selection.MoveRight Unit:=wdCell, Count:=1
' se fine file esco
If rsAnnUff.EOF Then Exit Do
If Riga > 51 Then
Riga = 2
End If
' nel caso sia il ruolo o il grado sono diversi da quelli precedenti,
' e mi trovo su una pagina dispari, devo inserire una pagina riportante
' la tabella vuota
If Not rsAnnUff!Grado = Grado Or Not rsAnnUff!Ruolo = Ruolo Then

Omissis per motivi di spazio

End If
If Not rsAnnUff!Ruolo = Ruolo Then
Ruolo = rsAnnUff!Ruolo
indice = 0
Riga = 2
PAGINA = 2
End If
If Riga = 2 Then
' Selection.TypeParagraph
docword.Selection.MoveDown Unit:=wdScreen, Count:=6
DoEvents
docword.Selection.InsertBreak Type:=wdPageBreak
DoEvents
Exit Do
End If
Loop
Loop
DoEvents
Screen.MousePointer = vbNormal
docword.Visible = True
Set docword = Nothing
DoEvents
Exit Sub
errore:
Screen.MousePointer = vbNormal
DoEvents
Set docword = Nothing
DoEvents
MsgBox Err.Description
End Sub