Algoritmia - Optimizar código tarda mucho en AddNew

Private Sub Combo129_AfterUpdate()

Dim rst As Recordset, rst1 As Recordset

Dim str As String, str1 As String

Dim dbs As Database, icuantos As Integer, Preg As Integer

Dim Irec As Integer

Dim txtFiltro As String

Set dbs = CurrentDb

icuantos = Me!Combo129

Preg = MsgBox("Al aceptar Ud. modificara el contenido de los detalles del Presupuesto" & Chr(13) & Chr(10) & _

    "¿Está Seguro de querer hacer ésto?", vbYesNo, "Modificará el contenido del Detalle del Presupuesto")

 If Preg = 7 Then GoTo Final

str = "SELECT Baremos.* From Baremos WHERE Baremos.IdBaremo = " & Me!Combo129

Set rst = dbs.OpenRecordset(str, dbOpenDynaset, dbSeeChanges)

    icuantos = rst.RecordCount

    Irec = rst!IdCirugía

    rst.Close

    str = "SELECT * FROM TipoProced"

    str = str & " WHERE TipoProced.Id=" & Irec

    Set rst = dbs.OpenRecordset(str, dbOpenDynaset, dbSeeChanges)

    icuantos = rst.RecordCount

    If (icuantos > 0) Then

            Me!Interv = rst!TipoProcedimiento

    End If

    rst.Close

str = "SELECT * FROM TipoBaremos WHERE TipoBaremos.IdBaremo=" & Me!Combo129

Set rst = dbs.OpenRecordset(str, dbOpenDynaset, dbSeeChanges)

icuantos = rst.RecordCount

If (icuantos > 0) Then

rst.MoveLast

rst.MoveFirst

icuantos = rst.RecordCount

Do While Not rst.EOF

str1 = "SELECT * FROM PresupuestoD"

Set rst1 = dbs.OpenRecordset(str1, dbOpenDynaset, dbSeeChanges)

rst1.AddNew

rst1!IdPresupuesto = Me!IdPresupuesto

rst1!CODSERVI = rst!CODSERVI

txtFiltro = "CODSERVI LIKE " & """" & rst1!CODSERVI & """"

If IsNull(DLookup("PorcIVA", "ListPrec", txtFiltro)) Then rst1!IVA = 0 Else rst1!IVA = DLookup("PorcIVA", "ListPrec", txtFiltro)

rst1!IdGasto = rst!IdGasto

rst1!IdSubGasto = rst!IdSubGasto

rst1!Descripción = rst!Descripción

rst1!Costo = Round(rst!Costo, 2)

rst1!Costo2 = 0

rst1!Cantidad = rst!Cantidad

rst1!Descuento = Round(rst!Descuento, 2)

rst1!Total = Round(rst1!Costo * rst1!Cantidad * (1 - ((rst!Descuento) / 100)), 2)

rst1!TotalIVA = Round(rst1!IVA * rst1!Total, 2)

rst1.Update

rst1.Close

rst.MoveNext

Loop

Me.Refresh

End If

rst.Close

Final:

End Sub