Corrección macro

Hola, elsa.
En el código que me armaste de búsqueda en otras hojas me ha ocurrido una cosa muy rara que es que al día de hoy funcionaba perfectamente pero ingrese un código nuevo en la hoja y me da un error no se si tiene que ver, adjunto todo lo que tiene armado la hoja y haber si le puedes dar un vistazo.
"el error que da es en el codigo Worksheet_Change en la segunda linea de Loop While (dice error de copilacion loop sin do)"
esta es todo lo que hay en la hoja:
Private Sub Worksheet_Activate()
Range("A20").Select
End Sub
---
Private Sub Worksheet_Calculate()
Resalta
End Sub
---
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Resalta
End Sub
--------
Private Sub Resalta()
Dim R As Long
Dim C As Long
Dim X As String
Dim z As Long
Dim y As Long
Dim a As String
R = ActiveCell.Row
C = ActiveCell.Column
X = Range("A19").Value
z = ActiveCell.Row
y = ActiveCell.Column
a = Range("a500").Value
If R < 20 Or R > 485 Or C < 1 Or C > 18 Or X = "" Then
Range("A20:T485").Interior.ColorIndex = 4
Else
Range("A20:T485").Interior.ColorIndex = 4
Range("A" & R & ":s" & R).Interior.ColorIndex = 27
End If
If z < 486 Or z > 1500 Or y < 1 Or y > 18 Or a = "" Then
Range("A486:T1500").Interior.ColorIndex = 7
Exit Sub
Else
Range("A486:T1500").Interior.ColorIndex = 7
Range("A" & R & ":s" & R).Interior.ColorIndex = 4
End If
End Sub
-----
Sub suposit()
UserForm1.Show
End Sub
----
Private Sub Worksheet_Change(ByVal Target As Range)
Dim fila1 As Integer
Dim rangoctrl As String, rangoBusq As String, dire1 As String
Dim hojaabuscar As String
'estos rangos deberás ajustarlos a los tuyos
rangoctrl = "A2"
hojaabuscar = "Hoja3"
rangoBusq = "A2:A2500"
If Not Application.Intersect(Target, Range(rangoctrl)) Is Nothing Then
Range("B2:E17").ClearContents
'guarda la fila para devolver los datos a partir de la misma
fila1 = Target.Row
Set encontrado = Sheets(hojaabuscar).Range(rangoBusq).Find(Target.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not encontrado Is Nothing Then
dire1 = encontrado.Address
Do
'devuelve en las col B , C y D
ActiveSheet.Cells(fila1, 2).Value = encontrado.Offset(0, 1).Value
ActiveSheet.Cells(fila1, 3).Value = encontrado.Offset(0, 2).Val
Set encontrado = Sheets(hojaabuscar).Range(rangoBusq).FindNext(encontrado)
Loop While Not encontrado Is Nothing And encontrado.Address <> ue
ActiveSheet.Cells(fila1, 4).Value = encontrado.Offset(0, 3).Value
fila1 = fila1 + 1
Set encontrado = Sheets(hojaabuscar).Range(rangoBusq).FindNext(encontrado)
Loop While Not encontrado Is Nothing
'este es el loop que me marca
And encontrado.Address <> dire1
End If
Set encontrado = Nothing
End If
End Sub
Espero que me puedas ayudar.
Gracias antemano y hasta pronto.