Slow macro

[Johan]

Hi, I have a macro with 5 different userforms which will help the user to get
the correct input. When I run the macro by steps (F8) the macro runs OK, but
when i run the macro by (F5) the macro slow very much down in speed.

I think the problem is the Userforms, but I am not sure. I have been using
Userform.hide and unlode Userform to see if it speeds up the macro, but
result is negative. Any one who has any sugestions?

Johan

 

[Joel]

You may want to add some break point using F9 to help find out what part of
the code is running slow. Set a break point in the middle of the code and
then run F5. then Press F5 again to run the 2nd part of the macro. Check if
the part before the break point is taking long or after the break point.
Move the break point or add multiple break points to isolate where the code
is running slow.

 

[Johan]

The macro as basic is searching for files on the computer and I know that it
is while searching the macro slowing down.
But I think, or it looks like , it have something to to with the user form
because it will no hide.
It seems that the macro not take its time to close the userform "properly"

Johan

Joel skrev:

 

[Patrick Molloy]

difficult without seeing your code.
are you updating sheets at all? if you are then try
Application.ScreenUpdating = False

 

[Johan]

This is my code:

Sub Autpen1()


Dim Path, MalNavn, SkipsValg, NyPath, NyDrive, NyPlass, IconName, Sep,
BookName, ShortCutFolder, _
BookFullName, DesktopPath, ShortcutFile, ShortcutMap, VismaNavn,
StandardNavn, NyFolder, Manual, _
Mnd, MndKatalog, Teller, Passord, FolderNavn, FulltNavn, Navn, KatNavn,
HistorieDato, Ny As String

Dim i, x, a, b, S_ID, ST_ID, Ã…r As Integer

Dim fs, oWsh, oShortcutFile, oShortcutMap As Object

Application.DisplayAlerts = False
Application.ScreenUpdating = False

UF_1.Show
Unload UF_1
Unload UF_2
Unload UF_3
Unload UF_4

Application.ScreenUpdating = True

Pause 10

NyDrive = Range("NyDrive")
NyFolder = Range("NyFolder")
Path = Range("Path")
MalNavn = Range("MalNavn")
FolderNavn = Range("FolderNavn")
SkipsValg = Range("SkipsValg")
VismaNavn = Range("VismaNavn")
S_ID = Range("S_ID")
Teller = Range("Teller").Address
Mnd = Range("Mnd")
NyPlass = NyDrive & NyFolder
StandardNavn = Range("StandardNavn")
MndKatalog = Range("MndKatalog")
Passord = Range("Passord")


'Manual = Range("Manual")
'FileCopy Path & Manual, NyDrive & NyFolder & Manual
FileCopy Path & "Arbeidslistelogg.xls", NyDrive & NyFolder &
"Arbeidslistelogg.xls"

Workbooks.Open Filename:=NyDrive & NyFolder & "Arbeidslistelogg.xls"
Sheets("Forside").Select
ActiveSheet.Unprotect Passord
Range("A2").Select
ActiveCell = SkipsValg
ActiveSheet.Protect Passord, DrawingObjects:=False, Contents:=True,
Scenarios:= _
False, AllowFormattingRows:=True

'Oppretter katalog for hver måned og flytter gamle filer til riktig
katalog
Windows("StartInstallasjonVer2.0.xls").Activate
Sheets("Formler").Select
For a = 1 To 12
Windows("StartInstallasjonVer2.0.xls").Activate
Range(Teller).Select
ActiveCell = a
If a < 10 Then
b = "0" & CStr(a)
Else: b = a
End If
If a < 9 Then
Ã…r = 2009
Else: Ã…r = 2008
End If
MndKatalog = Range("MndKatalog")
Mnd = Range("Mnd")
MkDir Mnd

Windows("Arbeidslistelogg.xls").Activate
Sheets(MndKatalog).Select
ActiveSheet.Unprotect Passord
Range("D6").Select
ActiveCell.Value = Ã…r

Set fs = Application.FileSearch
With fs
.LookIn = "C:\Arbeidsliste"
.SearchSubFolders = True
.Filename = "*" & b & Ã…r & ".xls"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
FulltNavn = .FoundFiles(i)
Navn =
CreateObject("Scripting.FileSystemObject").GetFileName(.FoundFiles(i))
KatNavn =
CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(.FoundFiles(i))
Windows("StartInstallasjonVer2.0.xls").Activate
Range("C36").Select
ActiveCell = Navn
Range("C37").Select
ActiveCell = FulltNavn

For x = 0 To 99
Range("D39").Select
ActiveCell = x
Range("E36").Select
If ActiveCell.Text = "ja" Then
Range("D37").Select
HistorieDato = ActiveCell.Value
GoTo Line4
End If

Next x
Line4:
Windows("Arbeidslistelogg.xls").Activate
Sheets(MndKatalog).Select
ActiveSheet.Unprotect Passord
Range("D" & HistorieDato + 9).Select
ActiveCell = Navn
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
Mnd & "\" & Navn, TextToDisplay:=Navn
Range(ActiveCell.Address).Offset(0, 1).Select
ActiveCell = Mnd
Range(ActiveCell.Address).Offset(0, 1).Select
ActiveCell = "'Fil fra tidligere versjon - Ingen informasjon
tilgjenglig. "

ActiveSheet.Protect Passord, DrawingObjects:=False,
Contents:=True, Scenarios:= _
False, AllowFormattingRows:=True

Ny =
CreateObject("Scripting.FileSystemObject").MoveFile(FulltNavn, Mnd & "\")


Next i
Else
End If
End With

Next a


Patrick Molloy skrev:

 

[Patrick Molloy]

all these DIM statements are incorrect

Dim i, x, a, b, S_ID, ST_ID, Ã…r As Integer
is effectively the same as
Dim i as variant, x as variant, a as variant, b as variant, S_ID as variant,
ST_ID as variant, Ã…r As Integer

while you mean
Dim i As Integer, x As Integer, a As Integer, b As Integer, S_ID As
Integer,ST_ID As Integer, Ã…r As Integer

old BASIC used to dim the way you use dit, but VBA needs explicit
dimensioning else variables are Variant by default


also, you don't need sheets or cell to be activated or selected to do stuff
with them

eg

Sheets("Forside").Select
Range("D6").Select
ActiveCell.Value = Ã…r

can be written
Sheets("Forside").Range("D6").Value = Ã…r

which will be much faster

 

[Johan]

Thank you I am very new into this. But why is the macro faster when using F8?

Johan

Patrick Molloy skrev:

 

[Johan]

How do I make a DoEvents in my code?

Johan

EricG skrev:

 

[EricG]

Just type "DoEvents" on the line right below "Application.ScreenUpdating =
True"

 

[Johan]

Sorry, but this does not speed up my macro.

Johan

EricG skrev:

 

[Joel]

There are a few things that is slowing down the code

1) Using select slow the code down. Especially using WINDOWS. Use workbook
instead
2) You don't need to create file system object over and over again. This
uses lots of memory.

See my changes below

Sub Autpen1()


Dim Path, MalNavn, SkipsValg, NyPath, NyDrive, NyPlass, IconName, Sep, _
BookName, ShortCutFolder, BookFullName, DesktopPath, ShortcutFile, _
ShortcutMap, VismaNavn, StandardNavn, NyFolder, Manual, _
Mnd, MndKatalog, Teller, Passord, FolderNavn, FulltNavn, Navn,
KatNavn, _
HistorieDato, Ny As String

Dim i, x, a, b, S_ID, ST_ID, Ã…r As Integer

Dim fs, oWsh, oShortcutFile, oShortcutMap As Object

Application.DisplayAlerts = False
Application.ScreenUpdating = False

UF_1.Show
Unload UF_1
Unload UF_2
Unload UF_3
Unload UF_4

Application.ScreenUpdating = True

Set Installbk = Workbooks("StartInstallasjonVer2.0.xls")
Set fso = CreateObject("Scripting.FileSystemObject")
Set fs = Application.FileSearch

With ThisWorkbook.ActiveSheet
NyDrive = .Range("NyDrive")
NyFolder = .Range("NyFolder")
Path = .Range("Path")
MalNavn = .Range("MalNavn")
FolderNavn = .Range("FolderNavn")
SkipsValg = .Range("SkipsValg")
VismaNavn = .Range("VismaNavn")
S_ID = .Range("S_ID")
Teller = .Range("Teller").Address
Mnd = .Range("Mnd")
NyPlass = NyDrive & NyFolder
StandardNavn = .Range("StandardNavn")
MndKatalog = .Range("MndKatalog")
Passord = .Range("Passord")


'Manual = .Range("Manual")
'FileCopy Path & Manual, NyDrive & NyFolder & Manual
FileCopy Path & "Arbeidslistelogg.xls", _
NyDrive & NyFolder & "Arbeidslistelogg.xls"

End With

Set bk = Workbooks.Open(Filename:=NyDrive & NyFolder & _
"Arbeidslistelogg.xls")

With bk.Sheets("Forside")
.Unprotect Passord
.Range("A2") = SkipsValg
.Protect Passord, DrawingObjects:=False, _
Contents:=True, _
Scenarios:=False, _
AllowFormattingRows:=True

'Oppretter katalog for hver måned og flytter gamle filer til riktig
'katalog
End With


For a = 1 To 12
With Installbk.Sheets("Formler")
.Range(Teller) = a
If a < 10 Then
b = "0" & CStr(a)
Else
b = a
End If

If a < 9 Then
Ã…r = 2009
Else
Ã…r = 2008
End If

MndKatalog = .Range("MndKatalog")
Mnd = .Range("Mnd")
MkDir Mnd
End With

With bk.Sheets(MndKatalog).Select
.Unprotect Passord
.Range("D6").Value = Ã…r

With fs
.LookIn = "C:\Arbeidsliste"
.SearchSubFolders = True
.Filename = "*" & b & Ã…r & ".xls"
End With

If fs.Execute() > 0 Then
For i = 1 To .FoundFiles.Count
FulltNavn = .FoundFiles(i)
Navn = fso.GetFileName(.FoundFiles(i))
KatNavn = fso.GetAbsolutePathName(.FoundFiles(i))

With Installbk.Sheets("Formler")
.Range("C36") = Navn
.Range("C37") = FulltNavn

For x = 0 To 99
.Range("D39") = x

If .Range("E36").Text = "ja" Then
HistorieDato = .Range("D37").Value
Exit For
End If

Next x
End With

.Unprotect Passord
Set MyCell = .Range("D" & HistorieDato + 9)
MyCell = Navn

.Hyperlinks.Add _
Anchor:=MyCell, _
Address:=Mnd & "\" & Navn, _
TextToDisplay:=Navn

MyCell.Offset(0, 1) = Mnd

MyCell.Offset(0, 1) = "'Fil fra tidligere versjon - " & _
"Ingen informasjon tilgjenglig. "

.Protect Passord, _
DrawingObjects:=False, _
Contents:=True, _
Scenarios:=False, _
AllowFormattingRows:=True

Ny = fso.MoveFile(FulltNavn, Mnd & "\")


Next i
End If
End With

Next a

End Sub