Speed up slow code? 90 seconds too long...!

[perola.rike]

As of yet I am not good at writing efficient codes, but hopefully I'll be some day. The code below exports a lot of data from excel to a formatted word report. How can this code be faster? It takes 90 seconds on my computer! (some of the 'comments are in Norwegian..)

Sub wordgenerator()

'Creates Word document of Auction Items using Automation

Sheets("generator").Visible = xlSheetVisible
Sheets("wordgenerator").Visible = xlSheetVisible
'her bør også en startkode som oppdaterer concatenate_oppmerksomhet etc (i tilfelle..)

'copygenerator som kopierer celler til wordgenerators som formateres og sendes til word(disse kan vel skrives sheets genereator.range xx.copy istedet for alle selct!)

'eksporterer fra resymert til og med NP data
Sheets("generator").Select
Range("G12:G101").Select
Selection.Copy
Sheets("wordgenerator").Select
Range("A1").Select
ActiveSheet.Paste

'eksporterer benyttede tester i domener
Sheets("generator").Select
Range("G102:G111").Select
Selection.Copy
Sheets("wordgenerator").Select
Range("A102").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'eksporterer vurdering/konklusjon
Sheets("generator").Select
Range("G112:G130").Select
Selection.Copy
Sheets("wordgenerator").Select
Range("A112").Select
ActiveSheet.Paste


Application.ScreenUpdating = False

'name that range!
'resymert
Range("A2").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="resymert_gen", RefersToR1C1:= _
"=wordgenerator!R2C1"
Range("A3").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="resymerttekst_gen", RefersToR1C1:= _
"=wordgenerator!R3C1"
'aktuelt
Range("A4").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Aktuelt_gen", RefersToR1C1:= _
"=wordgenerator!R4C1"
Range("A5").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Aktuelttekst_gen", RefersToR1C1:= _
"=wordgenerator!R5C1"
'egenrapportering
Range("A8").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Egenrapportering_gen", RefersToR1C1:= _
"=wordgenerator!R8C1"
Range("A9:A24").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Egenrapporteringtekst_gen", RefersToR1C1:= _
"=wordgenerator!R9C1:R24C1"
'nevropsykologiske testresultat
Range("A25").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPresultat_gen", RefersToR1C1:= _
"=wordgenerator!R25C1"
Range("A26").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPmerge", RefersToR1C1:= _
"=wordgenerator!R26C1"
Range("A27:A90").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPresultattekst_gen", RefersToR1C1:= _
"=wordgenerator!R27C1:R90C1"
'benyttede tester (virker)
Range("A102").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="overskriftbenyttedetester_gen", RefersToR1C1:= _
"=wordgenerator!R102C1"
Range("A103").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="benyttedemerge_gen", RefersToR1C1:= _
"=wordgenerator!R103C1"
Range("A104:A111").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="benyttedetester_gen", RefersToR1C1:= _
"=wordgenerator!R104C1:R111C1"
'Vurdering
Range("A112").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Vurdering_gen", RefersToR1C1:= _
"=wordgenerator!R112C1"
Range("A113").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Vurderingtekst_gen", RefersToR1C1:= _
"=wordgenerator!R113C1"
Range("A117").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Sted_dato", RefersToR1C1:= _
"=wordgenerator!R117C1"
Range("A118").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Undersøker_gen", RefersToR1C1:= _
"=wordgenerator!R118C1"
Range("A119").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Avd_sykehus", RefersToR1C1:= _
"=wordgenerator!R119C1"

'Sletter feilkoder som DIV/0, N/A Name? og tommme celler i wordgeneratorfanen
On Error Resume Next
Columns("A:A").SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete

'samler/concatenates alle np tester og benyttede tester i en celle!
merge
benyttedemerge

'Mot MS Word og forbi

Dim WordApp As Object
Dim LastRow As Integer, i As Integer, r As Integer, Records As Integer

On Error Resume Next
Application.ScreenUpdating = False

'Start Word And create an Object
Set WordApp = CreateObject("Word.Application")
With WordApp
.Documents.Add
End With

'Lagre som navn og path
WSName = "Oppstart"
'change "Sheet1" to sheet tab name containing cell reference
CName = "Navn"
'change "A1" to the cell with your date
'savename = Sheets(WSName).Range(CName).Text
SaveAsName = ThisWorkbook.Path & "\" & "Autorapport " & savename & ".doc"

'Sletter tomme celler
LastRow = Selection.SpecialCells(xlCellTypeLastCell).Rows.Row

Application.StatusBar = "Deleting Empty Rows from " & LastRow & " Used Rows"
'Cycle through all records In Items
On Error Resume Next
For r = LastRow To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r

'Update Last Row value In Case rows were deleted
'Sheets("wordgenerator").Range("A1:A200").FormatConditions.Delete
Records = ActiveSheet.UsedRange.Rows.Count

'Information from worksheet (her må du legge inn alle navn/range på celler som skal i autorapport (har med NP merge ikke NP resultattekst feks
Set Data = Sheets("wordgenerator").Range("A1")

resymert_gen = Sheets("wordgenerator").Range("resymert_gen")
Aktuelt_gen = Sheets("wordgenerator").Range("Aktuelt_gen")
Aktuelttekst_gen = Sheets("wordgenerator").Range("Aktuelttekst_gen")
Egenrapportering_gen = Sheets("wordgenerator").Range("Egenrapportering_gen")
Egenrapporteringtekst_gen = Sheets("wordgenerator").Range("Egenrapporteringtekst_gen")
NPresultat_gen = Sheets("wordgenerator").Range("NPresultat_gen")
NPmerge = Sheets("wordgenerator").Range("NPmerge")
overskriftbenyttedetester_gen = Sheets("wordgenerator").Range("overskriftbenyttedetester_gen")
benyttedemerge_gen = Sheets("wordgenerator").Range("benyttedemerge_gen")
Vurdering_gen = Sheets("wordgenerator").Range("Vurdering_gen")
Vurderingtekst_gen = Sheets("wordgenerator").Range("Vurderingtekst_gen")
Sted_dato = Sheets("wordgenerator").Range("Sted_dato")
Undersøker_gen = Sheets("wordgenerator").Range("Undersøker_gen")
Avd_sykehus = Sheets("wordgenerator").Range("Avd_sykehus")

'Cycle through all records In Items
For i = 2 To Records
'Update status bar progress message

Application.StatusBar = "Processing Record " & i & " of " & Records

' Assign current data To variables
Letter = Data.Offset(i - 1, 0).Value
Number = Data.Offset(i - 1, 1).Value
Title = Data.Offset(i - 1, 2).Value
Descript = Data.Offset(i - 1, 3).Value
FMV = Format(Data.Offset(i - 1, 4).Value, "#,000")
FMText = Data.Offset(i - 1, 5).Value
Donor = Data.Offset(i - 1, 6).Value

'Send commands To Word - dette er tekst som nå er formatert som sendes i den nøyaktige rekkefølge det står til word

With WordApp
.Documents.Add
With .Selection
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=resymert_gen
.TypeParagraph '(linjeskift)

'aktuelt
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=Aktuelt_gen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=Aktuelttekst_gen
.TypeParagraph

'egenrapportering
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=Egenrapportering_gen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=Egenrapporteringtekst_gen
.TypeParagraph

'NP resultater
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=NPresultat_gen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=NPmerge
.TypeParagraph

'benyttede tester under domenene som skal under profilark
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=overskriftbenyttedetester_gen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=benyttedemerge_gen
.TypeParagraph

'vurdering
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=Vurdering_gen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=Vurderingtekst_gen
.TypeParagraph
.Typetext Text:=Sted_dato
.TypeParagraph
.Typetext Text:=Undersøker_gen
.TypeParagraph
.Typetext Text:=Avd_sykehus

End With

End With
Next i

'Save the Word file And Close it
With WordApp
.ActiveDocument.SaveAs Filename:=SaveAsName
.ActiveWindow.Close
' Kill the Object
.Quit
End With

Set WordApp = Nothing

' Reset status bar
Application.StatusBar = ""
MsgBox "Autorapport " & savename & ".doc was saved in " & ThisWorkbook.Path

Sheets("generator").Visible = xlSheetVeryHidden
Sheets("wordgenerator").Visible = xlSheetVeryHidden
End Sub

 

[VoG]

Try without selecting. For example

'eksporterer fra resymert til og med NP data
Sheets("generator").Select
Range("G12:G101").Select
Selection.Copy
Sheets("wordgenerator").Select
Range("A1").Select
ActiveSheet.Paste

can be replaced by

'eksporterer fra resymert til og med NP data
Sheets("generator").Range("G12:G101").Copy Destination:=Sheets("wordgenerator").Range("A1")

 

[oldbrewer]

WOW - way above most of us......you may need to pay for a specialist consultant or buy some besplke software.

 

[Trevor G]

Look to add the application commands at the start of the code to stop displaying warnings, auto calculate and updates to false then do the code then put them back on

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
'your code
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

 

[perola.rike]

First off all, I restartet my computer (it's been a while). Only that speeded up the code from 90 to 37 seconds. Then I inserted all your suggestions, the code took only 25 seconds to run! Wow, thanks!

Look to add the application commands at the start of the code to stop displaying warnings, auto calculate and updates to false then do the code then put them back on