Macro que busca los datos que existen en un rango determinado y los guada como registros en otro lugar.

Para usted.

Tengo una macro que la copie de un archivo que encontré en Internet, yo la adapte a mi necesidad en un archivo quitandole campos y funciono a la perfección, pero quise dar un paso mas y en otro archivo la adapte agregándole mas campos que lo que tenia originalmente y cambiándolo de lugar y no funciona como debe ser, te explico: la macro original copia los datos que hay en una hoja sin importar que haya solo dos registros o 50 registros (la macro copia solo en las celdas que contienen datos) luego los gurda en otra hoja uno debajo de otro. Bueno la macro que adapte solo esta copiando y pegando un solo registro y no se porque no lo copia y pega todos, ya le he buscado todas las vueltas y nada, espero que me puedas ayudar. Aquí esta la macro.

Sub GUARDAR()
Application.ScreenUpdating = False
Sheets("FACTURA").Select

Range("H5").Select 'REGISTRO
NREG1 = ActiveCell.Value
ActiveCell.Offset(1, 0).Select

Range("H8").Select 'FECHA
FECH1 = ActiveCell.Value
ActiveCell.Offset(1, 0).Select

Range("B11").Select 'CODIGO
CODCLI1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Range("C11").Select 'NOMBRE Y APELLIDO
NOMAPELL1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Range("E11").Select 'APODO
APO1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Range("G11").Select 'CEDULA
CED1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select

Range("B13").Select 'PROFESION
PROF1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Range("C13").Select 'DIRECCION
DIR1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Range("E13").Select 'TELEFONO
TELE1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select
Range("G13").Select 'CELULAR
CEL1 = ActiveCell.Value
ActiveCell.Offset(0, 1).Select

Range("C14").Select
EMAIL1 = ActiveCell.Value 'EMAIL
ActiveCell.Offset(0, 1).Select

Range("C19").Select
While ActiveCell.Value <> ""

CODART1 = ActiveCell.Value 'CODIGO
ActiveCell.Offset(0, 1).Select
DESCART1 = ActiveCell.Value 'DESCRIPCION
ActiveCell.Offset(0, 1).Select
UNIDART1 = ActiveCell.Value 'UNIDAD
ActiveCell.Offset(0, 1).Select
CANTART1 = ActiveCell.Value 'CANTIDAD
ActiveCell.Offset(0, 1).Select
PRECUND1 = ActiveCell.Value 'PRECIO
ActiveCell.Offset(0, 1).Select
SUBTOTAL1 = ActiveCell.Value 'SUB TOTAL
ActiveCell.Offset(1, -5).Select
DIREC1 = ActiveCell.Address

Sheets("Registros").Select
Range("A3").Select
While ActiveCell.Value <> ""
ActiveCell.Offset(1, 0).Select
Wend
ActiveCell.Offset(-1, 0).Select
If ActiveCell.Value = "ID" Then
ID = 0
Else
ID = ActiveCell.Value
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = ID + 1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = NREG1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = FECH1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = CODCLI1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = NOMAPELL1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = APO1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = CED1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = PROF1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = DIR1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = TELE1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = CEL1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = EMAIL1
ActiveCell.Offset(0, 1).Select

ActiveCell.Value = CODART1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = DESCART1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = UNIDART1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = CANTART1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = PRECUND1
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = SUBTOTAL1
ActiveCell.Offset(0, 1).Select

Sheets("Registros").Select
Range("A3").Select

While ActiveCell.Value <> "" And ActiveCell.Value <> CODART1
ActiveCell.Offset(1, 0).Select
Wend

If ActiveCell.Value = CODART1 Then
ActiveCell.Offset(0, 17).Select
'ActiveCell.Value = ActiveCell.Value + SUBTOTAL1
End If

Sheets("FACTURA").Select
Range(DIREC1).Select
Range("D7").Select

Wend

'LIMPIAR2
'ActiveWorkbook.Save
Application.ScreenUpdating = True
End Sub