Ciclo con macros

Buenos dias
Tengo un problema resulta que en una hoja tengo el mismo formato donde extraigo unos datos y lo hago recorriendo las celdas hacia abajo el problema es que son muchas hacia abajo y ya extraigo lo datos mi problema radica en que como no se sabe cuantos hay hacia abajo puse un for con un rango de 800 pero se totea mi macro entonces no se como colocar hasta que termine de encontrar y extraer datos y encuentre solo ya espacio en blanco se saque sola y termina de ejecutar mi macro y no le puedo poner que cuando encuentre espacios en blanco ya que entre formato y formato hay espacios en blanco envio codigo como lo tengo, agradesco si me pueden colaborar.
Sub DATOS()
Dim stArchivoElegido As Variant
stArchivoElegido = Application.GetOpenFilename("Hoja Excel , *.xls*", _
, "INGRESE SU ARCHIVO PARA EJECUTAR")
Workbooks.Open stArchivoElegido
stArchivoElegido = ActiveWorkbook.Name
ActiveWindow.ScrollRow = 1
ActiveWindow.WindowState = xlNormal
Windows.Application.ScreenUpdating = False ' Esto es para que sea mas rapido Excel, no actualiza las ventanas
Workbooks(stArchivoElegido).Activate
Range("C17").Select
'If "" <= 30 Then
For i = 1 To 800
While ActiveCell.Value <> "Entidad"
ActiveCell.Offset(1, 0).Select
Wend
ActiveCell.Offset(2, 0).Select
If ActiveCell.Value <> "" Then
While ActiveCell.Value <> "jj" '"NUMERO DOCUMENTO"
If ActiveCell.Value <> ActiveCell.Offset(0, 6).Value Then
End If
ActiveCell.Offset(0, 1).Select
Wend
End If
Rem CAMPO NUMERO DOCUMENTO
ActiveCell.Offset(1, 0).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("B11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO FECHA REGISTRO
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("C11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO FECHA DE CREACION
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("D11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO ESTADO
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("E11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO VALOR INICIAL
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("F11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO VALOR OPERACIONES
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("G11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO VALOR ACTUAL
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("H11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Rem CAMPO DE VALOR DEDUCCIONES
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, 1).Select
Application.CutCopyMode = False
Selection.Copy
Windows("MACRO").Activate
Range("I11").Select
ActiveSheet.Paste Link:=True
Application.CutCopyMode = False
Windows("MACRO").Activate
Range("B11").Select
Selection.EntireRow.Insert
Workbooks(stArchivoElegido).Activate
ActiveCell.Offset(0, -38).Select
Next i
'End If
Windows.Application.ScreenUpdating = True
Workbooks(stArchivoElegido).Activate
ActiveWorkbook.Close
Range("B11:I11").Select
Selection.Interior.ColorIndex = 37
Selection.EntireRow.Insert
Selection.Interior.ColorIndex = 37
Selection.EntireRow.Insert
Range("B11").Select
End Sub
siempre es el mismo formato hacia abajo pero necesito que al finalizar se salga de la rutina.