Macro para ordenar datos

Hola, tengo esta macro que me ordena los datos que tengo en distintas hojas en una hoja nueva. La macro funciona correctamente, pero necesitaría que me pusiese el nombre de la hoja en la primera columna (de todos los registros que copie) ya que en este momento me pone el nombre de la hoja sólo en la celda anterior a comenzar a copiar los registros.
Para finalizar me gustaría quitar la fila de celdas vacías que aparece entre cada hoja copiada.
Sub MacroParaOrdenarDatos()
Fila = 1
    HojaActual = ActiveSheet.Name
    For i = 1 To 189
        Sheets(i).Select
        NombreHoja = ActiveSheet.Name
        Range("A1..D4").Select
        Selection.Copy
        Sheets(HojaActual).Select
        CeldaBase = "A" + Trim(Str(Fila))
        Range(CeldaBase).Select
        Selection.Value = NombreHoja
        Fila = Fila + 1
        CeldaBase = "A" + Trim(Str(Fila))
        Range(CeldaBase).Select
        Sheets(HojaActual).Paste
        Fila = Fila + 4       
    Next i
End Sub
Gracias.