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!

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