Speeding up macros

  • Thread starter Thread starter phil2006
  • Start date Start date
P

phil2006

Does anyone know how I could speed up the following:

Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim res As Variant

Set wks1 = Worksheets("travel1")
Set wks2 = Worksheets("travel2")

With wks2
FirstRow = 1
LastRow = .Cells(.Rows.Count, "k").End(xlUp).Row


For iRow = LastRow To FirstRow Step -1
res = Application.Match(.Cells(iRow, "b").Value, _
wks1.Range("a:a"), 0)

If IsError(res) Then
MsgBox "error"
Exit Sub
End If

wks1.Cells(res, 3).Insert Shift:=xlToRight
wks1.Cells(res, 3).Value = .Cells(iRow, "k").Value

With wks2
FirstRow = 1
LastRow = .Cells(.Rows.Count, "l").End(xlUp).Row

res = Application.Match(.Cells(iRow, "d").Value, _
wks1.Range("a:a"), 0)


wks1.Cells(res, 3).Insert Shift:=xlToRight
wks1.Cells(res, 3).Value = .Cells(iRow, "l").Value

'delete no good
Sheets("error").Select
Range("C4:H100").Select
Selection.Interior.ColorIndex = xlNone
Range("B3").Select
Selection.AutoFill Destination:=Range("B3:B4"),
Type:=xlFillDefault
Range("B3:B4").Select
Range("B4").Select
Selection.AutoFill Destination:=Range("B4:B100"),
Type:=xlFillDefault
Range("B4:B100").Select


If IsError(res) Then
MsgBox "error"
Exit Sub
End If

End With
Next iRow
End With
End Sub


Any help would be appreciated because they are very slow!

Thanks!
 
Nel post *phil2006* ha scritto:
Does anyone know how I could speed up the following:

Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim res As Variant

Set wks1 = Worksheets("travel1")
Set wks2 = Worksheets("travel2")

With wks2
FirstRow = 1
LastRow = .Cells(.Rows.Count, "k").End(xlUp).Row


For iRow = LastRow To FirstRow Step -1
res = Application.Match(.Cells(iRow, "b").Value, _
wks1.Range("a:a"), 0)

If IsError(res) Then
MsgBox "error"
Exit Sub
End If

wks1.Cells(res, 3).Insert Shift:=xlToRight
wks1.Cells(res, 3).Value = .Cells(iRow, "k").Value

With wks2
FirstRow = 1
LastRow = .Cells(.Rows.Count, "l").End(xlUp).Row

res = Application.Match(.Cells(iRow, "d").Value, _
wks1.Range("a:a"), 0)


wks1.Cells(res, 3).Insert Shift:=xlToRight
wks1.Cells(res, 3).Value = .Cells(iRow, "l").Value

'delete no good
Sheets("error").Select
Range("C4:H100").Select
Selection.Interior.ColorIndex = xlNone
Range("B3").Select
Selection.AutoFill Destination:=Range("B3:B4"),
Type:=xlFillDefault
Range("B3:B4").Select
Range("B4").Select
Selection.AutoFill Destination:=Range("B4:B100"),
Type:=xlFillDefault
Range("B4:B100").Select


If IsError(res) Then
MsgBox "error"
Exit Sub
End If

End With
Next iRow
End With
End Sub


Any help would be appreciated because they are very slow!

Thanks!
Click to expand...

Place this two lines after the Dims:

Application.ScreenUpdating =False
Application.Calculation =xlCalculationManual

your code

And before End Sub place this two more lines:

Application.ScreenUpdating =True
Application.Calculation = xlCalculationAutomatic


--
Hope I helped you.

Thanks in advance for your feedback.

Ciao

Franz Verga from Italy
 
Phil,
Use of .Select is seldom necessary. So
Sheets("error").Select
Range("C4:H100").Select
Selection.Interior.ColorIndex = xlNone
can become
Sheets("error").Range("C4:H100").Interior.ColorIndex = xlNone
etc...

NickHK
 
Hi Phil,

As Nick points out selections are rarely nrcessary and are usually
undesirable. Additionally, as Franz indicates, you could turn off the screen
refresh.

You may also wish to turn off automatic calculation.

Additionally, you have duplicated code blocks and you appear to repeat a
single operation (namely the autofill) in each loop.

Try, therefore:

'=============>>
Public Sub Tester003()
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim iRow As Long
Dim FirstRow As Long
Dim LastRow As Long
Dim res As Variant
Dim CalcMode As Long

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

Set wks1 = Worksheets("travel1")
Set wks2 = Worksheets("travel2")

With wks2
FirstRow = 1
LastRow = .Cells(.Rows.Count, "k").End(xlUp).Row


For iRow = LastRow To FirstRow Step -1
res = Application.Match(.Cells(iRow, "b").Value, _
wks1.Range("a:a"), 0)

If IsError(res) Then
MsgBox "error"
Exit Sub
End If

wks1.Cells(res, 3).Insert Shift:=xlToRight
wks1.Cells(res, 3).Value = .Cells(iRow, "k").Value
Next iRow
End With

'delete no good
With Sheets("error")
.Range("C4:H100").Interior.ColorIndex = xlNone
.Range("B3").AutoFill Destination:=.Range("B3:B4"), _
Type:=xlFillDefault
.Range("B4").AutoFill Destination:=Range("B4:B100"), _
Type:=xlFillDefault
End With

XIT:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub
'<<=============
 
Back
Top