Copiar un numero hacia abajo hasta un blank

Tengo un codigo y deseo que la informacion que se coloca en la celda "F6" se copie hacia abajo hasta el blank, como si hiciera la funcion del doble clic en la esquina de la celda.

Aqui esta el codigo que fue mejorado gracias a la ayuda de Dante Amor

'********Aplicacion Unificar archivos de excel(*.xlsx) en un solo libro----------
Sub Open_Files()
Dim Hoja As Object

Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.csv), *.csv", 2, "Abrir archivos",, True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
Workbooks. Add
'Captura nombre de archivo destino donde se grabaran los archivos seleccionados
A = ActiveWorkbook.Name
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
Workbooks.Open X(y)
b = ActiveWorkbook.Name
For Each Hoja In ActiveWorkbook.Sheets
Hoja.Copy after:=Workbooks(A).Sheets(Workbooks(A).Sheets.Count)
num = Right(Workbooks(A).Sheets(Workbooks(A).Sheets.Count).[A3], 4)
Workbooks(A).Sheets(Workbooks(A).Sheets.Count).[F6] = num
Next
Workbooks(b).Close False
Next
Application.StatusBar = "Listo"
Call Unir_Hojas
End If
Application.ScreenUpdating = False
End Sub

Sub Unir_Hojas()
Dim Sig As Byte, Eliminar As Boolean
For Sig = 2 To Worksheets.Count
Worksheets(Sig).UsedRange.Copy _
Worksheets(1).Range("a1000000").End(xlUp).Offset(1)
Next
Application.DisplayAlerts = False
For Sig = 2 To Worksheets.Count
Worksheets(2).Delete
Next
Application.DisplayAlerts = True

End Sub