Como reducir tiempo de una macro

¿M pueden ayidar a reducir el tiempo de ejecución de una Macro?

Toma un minuto y medio.

La macro es con bucle. A continuación la paso:

Set h1 = Sheets("ciclo_operativo")
Set h2 = Sheets("Ejecutivo")
Msg = MsgBox("Enrique, Quieres borrar el contenido del reporte ejecutivo?", vbYesNo, "Reporte de Ciclos")
If Msg <> 6 Then
Exit Sub
End If
h2.Range("A2:L200000").ClearContents
Dim i As Long
On Error Resume Next
For i = 1 To Rows.Count
h2row = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
If h1.Cells(i, 2) = h1.Cells(i + 1, 2) And Left(h1.Cells(i, 6), 6) = "Planta" And Left(h1.Cells(i + 1, 6), 5) = "Dist." Then
h2.Cells(h2row, 1) = h1.Cells(i, 1)
h2.Cells(h2row, 2) = h1.Cells(i, 2)
h2.Cells(h2row, 3) = h1.Cells(i, 3)
h2.Cells(h2row, 4) = h1.Cells(i, 6)
h2.Cells(h2row, 5) = h1.Cells(i + 1, 6)
h2.Cells(h2row, 6) = h1.Cells(i, 8)
h2.Cells(h2row, 7) = h1.Cells(i, 17)
h2.Cells(h2row, 8) = h1.Cells(i, 18)
h2.Cells(h2row, 9) = h1.Cells(i + 1, 8)
h2.Cells(h2row, 10) = h1.Cells(i + 1, 17)
h2.Cells(h2row, 11) = h1.Cells(i + 1, 18)
h2.Cells(h2row, 12) = h1.Cells(i + 1, 18) - h1.Cells(i, 8)
End If
If h1.Cells(i, 2) = h1.Cells(i + 1, 2) And Left(h1.Cells(i, 6), 6) = "Planta" And Left(h1.Cells(i + 1, 6), 3) = "Tek" And Left(h1.Cells(i + 2, 6), 5) = "Dist." Then
h2.Cells(h2row, 1) = h1.Cells(i, 1)
h2.Cells(h2row, 2) = h1.Cells(i, 2)
h2.Cells(h2row, 3) = h1.Cells(i, 3)
h2.Cells(h2row, 4) = h1.Cells(i, 6)
h2.Cells(h2row, 5) = h1.Cells(i + 2, 6)
h2.Cells(h2row, 6) = h1.Cells(i, 8)
h2.Cells(h2row, 7) = h1.Cells(i, 17)
h2.Cells(h2row, 8) = h1.Cells(i, 18)
h2.Cells(h2row, 9) = h1.Cells(i + 2, 8)
h2.Cells(h2row, 10) = h1.Cells(i + 2, 17)
h2.Cells(h2row, 11) = h1.Cells(i + 2, 18)
h2.Cells(h2row, 12) = h1.Cells(i + 2, 18) - h1.Cells(i, 8)
End If
Next i
End Sub