Run time keeps expanding - ms-access

Question

The code below starts with a second or less between each record and slowly increases until each record takes 15 seconds at the 500th record. Memory went from 130 Mb to 430 Mb. I have 5000 records to process so anything to speed this up would be appreciated.
[NOTE: Updating via RecordSet also expands and takes more time]
Public Sub Update_Main_Data()
Dim sql_Read As String
Dim db As DAO.Database
Dim rst_Read As DAO.Recordset, rst_Write As DAO.Recordset
Dim New_CMID As Integer, New_Lead As Integer, New_GI As Integer, New_PMO As Integer
Dim New_Dist As Integer, New_Phase As Integer, New_Type As Integer, New_Finance As Integer
DoCmd.SetWarnings False
Qoute_Char = Chr(34)
Last_Number = Qoute_Char & "AF00379-001" & Qoute_Char
sql_Read = ""
sql_Read = sql_Read & "Select ID, Contract_Number, Project_Type, Old_Type, CM, Old_CM, "
sql_Read = sql_Read & "Contract_Lead, Old_Lead, GI_PM, Old_GI, MPO_PM, Old_MPO, "
sql_Read = sql_Read & "Distrib_Contact, Old_Dist, FinanceReplacementCPUC, Old_Finance, "
sql_Read = sql_Read & "Contract_Phase, Old_Phase from [tblTrue-UpMain1] "
sql_Read = sql_Read & "WHERE Contract_Number > " & Last_Number & " ORDER BY Contract_Number"
Set db = CurrentDb
Set rst_Read = db.OpenRecordset(sql_Read)
RecNum = 0
rst_Read.MoveFirst
Do Until rst_Read.EOF
Starting_Time = Now()
Time_Start = Timer()
RecNum = RecNum + 1
If IsNull(rst_Read!Old_CM) Then
New_CMID = 0
Else
New_CMID = Nz(DLookup("CMID", "tblContractManagers1", "Old_ID = " & rst_Read!Old_CM), 0)
End If
If IsNull(rst_Read!Old_Lead) Then
New_Lead = 0
Else
New_Lead = Nz(DLookup("CMID", "tblContractManagers1", "Old_ID = " & rst_Read!Old_Lead), 0)
End If
If IsNull(rst_Read!Old_GI) Then
New_GI = 0
Else
New_GI = Nz(DLookup("ID", "tblGI-PM1", "Old_ID = " & rst_Read!Old_GI), 0)
End If
If IsNull(rst_Read!Old_MPO) Then
New_MPO = 0
Else
New_MPO = Nz(DLookup("ID", "tblPMO-PM1", "Old_ID = " & rst_Read!Old_MPO), 0)
End If
If IsNull(rst_Read!Old_Dist) Then
New_Dist = 0
Else
New_Dist = Nz(DLookup("ID", "tblDistContact1", "Old_ID = " & rst_Read!Old_Dist), 0)
End If
If IsNull(rst_Read!Old_Phase) Then
New_Phase = 0
Else
New_Phase = Nz(DLookup("ID", "tblContract_Phase1", "PhaseID = " & rst_Read!Old_Phase), 0)
End If
If IsNull(rst_Read!Old_Type) Then
New_Type = 0
Else
New_Type = Nz(DLookup("ID", "tblContract_Types1", "Old_ID = " & rst_Read!Old_Type), 0)
End If
If IsNull(rst_Read!Old_Finance) Then
New_Finance = 0
Else
New_Finance = Nz(DLookup("ID", "tblFinanceReplacement1", "Old_ID = " & rst_Read!Old_Finance), 0)
End If
Main_String = ""
Main_String = Main_String & "UPDATE [tblTrue-UpMain1] SET [tblTrue-UpMain1].CM = " & New_CMID
Main_String = Main_String & ", [tblTrue-UpMain1].Contract_Lead = " & New_Lead & ", [tblTrue-UpMain1].GI_PM = " & New_GI
Main_String = Main_String & ", [tblTrue-UpMain1].MPO_PM = " & New_PMO & ", [tblTrue-UpMain1].Distrib_Contact = " & New_Dist
Main_String = Main_String & ", [tblTrue-UpMain1].Contract_Phase = " & New_Phase & ", [tblTrue-UpMain1].Project_Type = " & New_Type
Main_String = Main_String & ", [tblTrue-UpMain1].FinanceReplacementCPUC = " & New_Finance
Main_String = Main_String & " WHERE ((([tblTrue-UpMain1].ID)=" & rst_Read!ID & "));"
DoCmd.RunSQL Main_String
Ending_Time = Now()
Time_End = Timer()
Curr_Num = Qoute_Char & rst_Read!Contract_Number & Qoute_Char
Time_String = ""
Time_String = Time_String & "INSERT INTO Contract_Time1 ( Contract_Number, "
Time_String = Time_String & "End_Time, Start_Time, Elasped_Time )"
Time_String = Time_String & "SELECT " & Curr_Num & " as New_Num, #" & Ending_Time
Time_String = Time_String & "# As New_End , #" & Starting_Time & #" as New_Start, "
Time_String = Time_String & Time_End - Time_Start & " as new_Time"
DoCmd.RunSQL Time_String
rst_Read.MoveNext
Loop
End Sub