Selección de datos a traspasar a hoja de Microsoft Excel con códigos en macro

Lo que sucede es que tengo que pasar unos datos repetidos de una hoja de excel a otra como se ve aquí
permiso|propietario|cedula etc etc y tengo este código en una macro
Sub probando()
Dim Permiso As Long
Dim Predio, Vereda, Municipio, Valor As String
Dim celda As String
Permiso = InputBox("Escriba el Permiso a buscar")
Sheets("Hoja1").Select
Range("A30").Select
Do While ActiveCell.Value <> ""
If ActiveCell.Value = Permiso Then
celda = ActiveCell.Address
Predio = ActiveCell.Offset(0, 4).Text
Vereda = ActiveCell.Offset(0, 5).Text
Municipio = ActiveCell.Offset(0, 6).Text
Valor = ActiveCell.Offset(0, 15).Text
End If
If ActiveCell.Value <> "" Then
Sheets("Hoja2").Select
ActiveSheet.Range("B22").Select
ActiveCell.Value = "Permiso"
ActiveCell.Offset(0, 1).Value = "Predio"
ActiveCell.Offset(0, 2).Value = "Vereda"
ActiveCell.Offset(0, 3).Value = "Municipio"
ActiveCell.Offset(0, 5).Value = "Valor"
ActiveCell.Offset(1, 0).Select
Do
Do While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Loop
Loop Until check = ""
If ActiveCell.Value = "" Then
ActiveCell.Value = Permiso
ActiveCell.Offset(0, 1).Value = Predio
ActiveCell.Offset(0, 2).Value = Vereda
ActiveCell.Offset(0, 3).Value = Municipio
ActiveCell.Offset(0, 5).Value = Valor
Else
Exit Do
End If
End If
Sheets("Hoja1").Select
Range(celda).Select
ActiveCell.Offset(1, 0).Select
Loop
End Sub
¿El código me pasa los datos que necesito pero al final empieza a repetirme el ultimo dato de una y otra y otra vez... Como puedo detener este bucle para que tan solo me sagan los datos que son sin que se me repitan? Por favor necesito tu ayuda... Te lo agradecería.