Mecros excel
Buenos días, tengo varios archivos de excel con diferentes nombres y día a día se generan más archivos y se modifican los actuales, mi necesidad es crear un solo libro en el cual al mismo tiempo pueda tomar los datos de todos ellos (ya que el formato del contenido es siempre el mismo). Los archivos se encuentran todos en una misma carpeta.
Espero puedan ayudarme, hace mucho que estoy tratando de resolver este problema y por suerte los descubrí a ustedes!
Espero puedan ayudarme, hace mucho que estoy tratando de resolver este problema y por suerte los descubrí a ustedes!
1 Respuesta
Respuesta de parmijo
1
Vamos a ver si te Funciona con este par de macros
Sub Listar()
' Con esta macro obtienes la lista de direcctorios de una carpeta
Sheets("Hoja2").Select
Dim i As Long
Dim MiRuta As String
Dim MiNombre As String
i = 1
MiRuta = "C:\nueva carpeta\*.xls" 'Aca esta el direcctorio de tus archivos
MiNombre = Dir(MiRuta, 0)
Do While MiNombre <> ""
If MiNombre <> "." And MiNombre <> ".." Then
Range("A" & i) = MiNombre
i = i + 1
End If
MiNombre = Dir
Loop
End Sub
Luego Tienes que la otra macro que recorre la lista y capta los datos:
Sub ListaDir()
Sheets("Hoja2").Select ' donde esta la lista
Range("A1").Select ' rango de donde empieza la lista
Selection.End(xlDown).Select
x4 = ActiveCell.Row
x5 = x4 - 1 + 1
Range("A1").Select ' OBTENENOS LA CANTIDAD DE DATOS
For Z = 1 To x5
Sheets("Hoja2").Select
ruta = "ODBC;DSN=Excel Files;DBQ=C:\nueva carpeta\" & ActiveCell.Value & ";DefaultDir=C:\"
'TIENES QUE REEMPLAZAR C:\nueva carpeta\ POR EL DIRECCTORIO QUE CORRESPONDE
ruta2 = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Sheets("Hoja1").Select ' hoja donde se dejan los datos
Range("a1").Select
Do While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
Loop
destino = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
ruta), Array("nueva carpeta;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;")), Destination:=Range(destino))
.CommandText = Array("SELECT `Hoja1.Nombre, `Hoja1.RUT" & Chr(13) & "" & Chr(10) & "FROM `Hoja1 `Hoja1" & Chr(13) & "" & Chr(10) & "ORDER BY `Hoja1.Nombre")
'En esta consulta se extrae solamente los campos Nombre y rut del archivo leccionado
.Name = "Consulta desde Excel Files"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
Next
End Sub
Sub Listar()
' Con esta macro obtienes la lista de direcctorios de una carpeta
Sheets("Hoja2").Select
Dim i As Long
Dim MiRuta As String
Dim MiNombre As String
i = 1
MiRuta = "C:\nueva carpeta\*.xls" 'Aca esta el direcctorio de tus archivos
MiNombre = Dir(MiRuta, 0)
Do While MiNombre <> ""
If MiNombre <> "." And MiNombre <> ".." Then
Range("A" & i) = MiNombre
i = i + 1
End If
MiNombre = Dir
Loop
End Sub
Luego Tienes que la otra macro que recorre la lista y capta los datos:
Sub ListaDir()
Sheets("Hoja2").Select ' donde esta la lista
Range("A1").Select ' rango de donde empieza la lista
Selection.End(xlDown).Select
x4 = ActiveCell.Row
x5 = x4 - 1 + 1
Range("A1").Select ' OBTENENOS LA CANTIDAD DE DATOS
For Z = 1 To x5
Sheets("Hoja2").Select
ruta = "ODBC;DSN=Excel Files;DBQ=C:\nueva carpeta\" & ActiveCell.Value & ";DefaultDir=C:\"
'TIENES QUE REEMPLAZAR C:\nueva carpeta\ POR EL DIRECCTORIO QUE CORRESPONDE
ruta2 = ActiveCell.Value
ActiveCell.Offset(1, 0).Select
Sheets("Hoja1").Select ' hoja donde se dejan los datos
Range("a1").Select
Do While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
Loop
destino = ActiveCell.Address(RowAbsolute:=False, ColumnAbsolute:=False)
With ActiveSheet.QueryTables.Add(Connection:=Array(Array( _
ruta), Array("nueva carpeta;DriverId=1046;MaxBufferSize=2048;PageTimeout=5;")), Destination:=Range(destino))
.CommandText = Array("SELECT `Hoja1.Nombre, `Hoja1.RUT" & Chr(13) & "" & Chr(10) & "FROM `Hoja1 `Hoja1" & Chr(13) & "" & Chr(10) & "ORDER BY `Hoja1.Nombre")
'En esta consulta se extrae solamente los campos Nombre y rut del archivo leccionado
.Name = "Consulta desde Excel Files"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.PreserveColumnInfo = True
.Refresh BackgroundQuery:=False
End With
Next
End Sub
Ante todo quiero agradecerte muchísimo por tu ayuda! La macro que me pasaste primero anda perfecta en la segunda hoja me hace un listado con los nombres de los archivos; pero en la segunda tengo un problema en la sección ".Refresh BackgroundQuery:=False" y los datos de las planillas no llegan a copiarse.. ¿podrías ayudarme?
Recuerda que en esta parte debes modificar el código según tus planillas:
= Array("SELECT `Hoja1.Nombre, `Hoja1.RUT" & Chr(13) & "" & Chr(10) & "FROM `Hoja1 `Hoja1" & Chr(13) & "" & Chr(10) & "ORDER BY `Hoja1.Nombre")
Si Gustas enviame tu planilla por correo
[email protected]
= Array("SELECT `Hoja1.Nombre, `Hoja1.RUT" & Chr(13) & "" & Chr(10) & "FROM `Hoja1 `Hoja1" & Chr(13) & "" & Chr(10) & "ORDER BY `Hoja1.Nombre")
Si Gustas enviame tu planilla por correo
[email protected]
Me siento afortunada de conocerte, gracias por tus ganas de ayudar a la gente, y por haberme ayudado tanto a mi! Te admiro por tu conocimiento! Muchísimas Gracias.
