Buenas Noches, encontre un archivo con una macro para un archivo de consolidacion que estoy generando, pero no encuentro la forma de que junto con la informacion, en cada fila, me ponga en la celda de la "E" correspondiente, el nombre del archivo del cual esta obteniendo la informacion.

Espero alguien pueda ayudarme con este tema.

Incluyo archivo zip con el ejemplo.

Saludos

Consolidacion.zip

A ver si es esto:

Sub Consolidar()


    ChDir (ActiveWorkbook.Path)

    ruta = ActiveWorkbook.Path

    nonfic = ActiveWorkbook.Name

    arch = Dir("*.xls")

    fil = 1

    Do Until arch = ""

        If arch = nonfic Then GoTo Salto

        Workbooks.Open Filename:=arch, UpdateLinks:=0

        Range("A1:D100").Copy

        Windows(nonfic).Activate

        uf = Range("A65536").End(xlUp).Row + 1

        Range("A" & uf).PasteSpecial

        Range("E" & uf) = ActiveWorkbook.Name '<==============

        Windows(arch).Activate

        ActiveWorkbook.Close

Salto:

        arch = Dir

    Loop


End Sub



[/CODE]

Gracias Macro Antonio, desafortunadamente el resultado no es el deseado, ya que arroja el nombre del archivo "Consolidacion.xls", y se necesita que arroje el nombre "1. Almacen Jamaica", por ejemplo. Gracias voy a seguir intentando, tambien agradezco la ayuda de los miembros del foro.

Saludos

Hola! Jicotillo (y Antoni).

Es un "toque menor" lo que hay que hacer al código mostrado por Antoni.

Sin embargo (y por las dudas) te pido dos ampliaciones de concepto:

a) Los archivos de donde se toma la info para copiarla: ¿SIEMPRE tienen la tabla de datos en la primera hoja del libro? (lo pregunto pues el código planteado "supone" que al abrir esos archivos SIEMPRE veremos la hoja con los datos como ACTIVA, pero ello puede no ser así...).

Las tablas de datos: ¿SIEMPRE tienen 100 filas de datos? ¿Pueden ser más?

Si respondes a estas dos preguntas quedaría todo aclarado.

Saludos, Cacho R.

Bueno ,

a) Si, siempre tienen la tabla de datos en la primera hoja.

Las tablas, pueden tener mas de dos mil filas. Pero solo seria en el caso de dos almacenes, son mas del 100 almacenes, aunque para este caso solo estoy tomando 3, para ver como va funcionando la macro.

Considerando estas dos aclaraciones podrías intentar:

Sub Consolidar()
Dim arch$, myCell As Range

Application.ScreenUpdating = False
Intersect([a1].CurrentRegion, [a:d]).Offset(1).Delete xlShiftUp
Set myCell = [a2]
arch = Dir(ThisWorkbook.Path & "\*.xls")

While arch <> ""
  If ThisWorkbook.Name <> arch Then
    With Workbooks.Open(ThisWorkbook.Path & "\" & arch, 0, True).Sheets(1)
      Intersect(.[a1].CurrentRegion, .[a:d]).Copy
      myCell.PasteSpecial: Application.CutCopyMode = xlCopy
      .Parent.Close False
    End With
  End If
  Set myCell = [a65536].End(xlUp).Offset(1)
  arch = Dir
Wend

Application.ScreenUpdating = True
Set myCell = Nothing
End Sub[/PHP]

Saludos, Cacho R.

[u]P.D.[/u]

Antoni: cualquier "cosita" para agregar... ¡Ya sabes!

Gracias Cacho R, pero el resultado fue el mismo que el del primer archivo, con la diferencia que ya no tiene el molesto aviso del portapapeles, que opinas.

Gracias Cacho R, pero el resultado fue el mismo que el del primer archivo, con la diferencia que ya no tiene el molesto aviso del portapapeles, que opinas.

¿Qué opino?... Pues opino que por poner el énfasis en tus últimos comentarios, se "me pasó" lo de tu "columna E" (jajajajaja).

Te muestro la versión completa, entonces:

Sub Consolidar2()
'-------------------
' By Cacho Rodríguez
'-------------------
Dim arch$, myCell As Range, Rng As Range

Application.ScreenUpdating = False
Intersect([a1].CurrentRegion, [a:d]).Offset(1).Delete xlShiftUp
Set myCell = [a2]
arch = Dir(ThisWorkbook.Path & "\*.xls")

While arch <> ""
  If ThisWorkbook.Name <> arch Then
    With Workbooks.Open(ThisWorkbook.Path & "\" & arch, 0, True).Sheets(1)
      Set Rng = Intersect(.[a1].CurrentRegion, .[a:d])
      Rng.Copy
      myCell.PasteSpecial: Application.CutCopyMode = xlCopy
      myCell.Offset(, 4).Resize(Rng.Rows.Count) = .Parent.Name
      .Parent.Close False
    End With
  End If
  Set myCell = [a65536].End(xlUp).Offset(1)
  arch = Dir
Wend

With [a1].CurrentRegion
  With .Font
    .Name = "Calibri"
    .Size = 9
  End With
  .Columns.AutoFit
End With

[a1].CurrentRegion.Columns.AutoFit
Application.ScreenUpdating = True
Set Rng = Nothing: Set myCell = Nothing
End Sub[/PHP]

Sorry, entonces, por lo anterior.

Saludos, Cacho R.

gracias cacho,ajajajjaja yo opino que wow en verdad funciona, entiendo que empezaste con el rng as range para lograrlo, pero lo demas no lo entiendo, me gustaria pudieras ilustrarme.

... me gustaria pudieras ilustrarme.

Te adjunto la misma versión pero -ahora- incluyendo comentarios: ¿Te sirve como para orientarte?

Consolidacion.xls

Gracias si que me ilustra, por cierto, hay un detalle, al parecer, si existe una fila en blanco, no la copia y termina con la copia de ese archivo y continua con el siguiente.

De momento lo soluciones asi:

Consideando que las lineas en blanco, podian variar de archivo a archivo, y que ninguno pasa de 3000.

Entonces quite esta parte

Set Rng = Intersect(.[a1].CurrentRegion, .["$a:$d"])

y la cambie por

Set Rng = Range("a6:k3000")

Lo cual de momento me sirve, aunque me hubiera gustado mas la idea de que no tomara en cuenta las filas vacias, para saltar de archivo.

De igual forma gracias por su atencion y ayuda, que como siempre fue genial.