Visual Basic - Necesito cuadrar datos pegados entre hojas con rangos variables

Estimados antes que nada dar las gracias por todo lo que enseñan a personas como yo, bueno les cuento tengo na macro que debe copiar solo unas columnas especificas en otra hoja las que a su vez se deben copiar tres veces.
logro copiarlas pero las columnas que están con datos consecutivos están bien ya que es obligatorio la fecha el problema es cuando copio las otras se descuadran porque algunas columnas tienen datos en blanco.
necesito que la tabla principal o base se traspase en forma pareja lo que no he logrado adjunto el archivo.

Sub Macro2()

REPETIR = 3

For Q = 1 To REPETIR

Sheets("OXIGENO URG").Select
ActiveSheet.ListObjects("OXIM").ListColumns(2).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("C2").Range("A1000000").End(xlUp).Offset(1, 0) ' FECHA
ActiveSheet.ListObjects("OXIM").ListColumns(3).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("D2").Range("A1000000").End(xlUp).Offset(1, 0) ' NOMBRE
ActiveSheet.ListObjects("OXIM").ListColumns(4).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("E2").Range("A1000000").End(xlUp).Offset(1, 0) ' IDENTIDAD
ActiveSheet.ListObjects("OXIM").ListColumns(5).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("J2").Range("A1000000").End(xlUp).Offset(1, 0) ' L_PAGO
Next Q
Application.CutCopyMode = False
ActiveSheet.ListObjects("OXIM").ListColumns(7).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("M2").Range("A1000000").End(xlUp).Offset(1, 0) ' AM
ActiveSheet.ListObjects("OXIM").ListColumns(8).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("O2").Range("A1000000").End(xlUp).Offset(1, 0) ' NPAM
ActiveSheet.ListObjects("OXIM").ListColumns(12).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("M2").Range("A1000000").End(xlUp).Offset(1, 0) ' PM
ActiveSheet.ListObjects("OXIM").ListColumns(13).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("O2").Range("A1000000").End(xlUp).Offset(1, 0) ' NPPM
ActiveSheet.ListObjects("OXIM").ListColumns(17).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("M2").Range("A1000000").End(xlUp).Offset(1, 0) ' NO
ActiveSheet.ListObjects("OXIM").ListColumns(18).DataBodyRange.Copy Destination:=Sheets("Hoja3").Range("O2").Range("A1000000").End(xlUp).Offset(1, 0) ' NPNO
End Sub


nota no puedo subir adjunto

mil gracias de antemano por la ayuda