Bisection Method VBA Code Problem

I have a test this Friday and I still can't get my Excel code for Bisection Method to run properly. The problem is that the program only runs 1 iteration, instead of running the loops until the approximate relative error is less than the tolerance value. How do I solve this?

This is my code :

Sub bisection()
Dim i As Integer
Dim a As Double, b As Double, abserror As Double, xm As Double, f1 As Double, f2 As Double, fm As Double, TOL As Double
a = InputBox("Enter the value of the lower bound")
b = InputBox("Enter the value of the upper bound")
TOL = InputBox("Enter the value of the TOL")
f1 = 3 * a + Sin(a) - Exp(a)
f2 = 3 * b + Sin(b) - Exp(b)
If f1 * f2 < 0 Then
MsgBox ("There is at least one root within this interval")
For i = 1 To 5000 Step 1
xm = (a + b) / 2
fm = 3 * xm + Sin(xm) - Exp(xm)
f1 = 3 * a + Sin(a) - Exp(a)
f2 = 3 * b + Sin(b) - Exp(b)
If f1 * fm < 0 Then
a = a
b = xm
abserror = (Abs(xm - b) / xm) * 100
Worksheets("Sheet1").Cells(i, 1) = i
Worksheets("Sheet1").Cells(i, 2) = a
Worksheets("Sheet1").Cells(i, 3) = b
Worksheets("Sheet1").Cells(i, 4) = xm
Worksheets("Sheet1").Cells(i, 5) = f1
Worksheets("Sheet1").Cells(i, 6) = f2
Worksheets("Sheet1").Cells(i, 7) = abserror
Else
a = xm
b = b
abserror = (Abs(xm - a) / xm) * 100
Worksheets("Sheet1").Cells(i, 1) = i
Worksheets("Sheet1").Cells(i, 2) = a
Worksheets("Sheet1").Cells(i, 3) = b
Worksheets("Sheet1").Cells(i, 4) = xm
Worksheets("Sheet1").Cells(i, 5) = f1
Worksheets("Sheet1").Cells(i, 6) = f2
Worksheets("Sheet1").Cells(i, 7) = abserror
End If
If abserror <= TOL Then
MsgBox ("Root = " & xm & ", Iteration = " & i & ", Approximate Relative Percentile Error = " & abserror & " ")
Exit For
Else
End If
Next i


Else
MsgBox ("There are no roots within this interval")
End If

End Sub


Thank you in advance! :D