Macro agrupar datos de varios libros a un excel
Tengo en una carpeta muchos excels y lo que quisiera que me hiciera la macro es que en Excel nuevo me haga lo siguiente:
Que de la carpeta que tengo todos los excels me vaya abriendo Excel por Excel y me copia en formato valor los siguientes datos:
De la de la hoja DATOS EMPRESA que me copie como valor al excels resumen las celdas B1 y B2 y que me lo ponga en la hoja del nuevo excel en A4 - A5,
También que me coja de la hoja PyG las celdas B28, C28 y D28 y que me lo copia como valor en el Excel resumen en las celdas A6-A7-A8,
Y así con todos los excels de la carpeta, me gustaría que cada vez que copie los datos de los Excel al Excel resumen me deje una fila en blanco, o sea sin datos, para verlo mas claro
Creo que la pregunta que hice hace un rato no fue enviada, si se ha enviado dos veces, pido disculpas
1 Respuesta
Te anexo la macro. Pon la macro en un archivo nuevo.
Cambia lo siguiente en la macro:
La ruta "c:\trabajo\" por la carpeta donde tienes los archivos.
La hoja "resumen" por el nombre de tu hoja en el libro nuevo donde quieres el resumen de los datos.
Sub Pasar_Valores()
'Por Dante Amor
'Pasar valores de varios archivos a la hoja resumen
'
Dim sh As Worksheet
Dim l2 As Workbook
Dim ruta As String
Dim arch As Variant
Dim hoja1 As String, hoja2 As String
Dim esta1 As Boolean, esta2 As Boolean
Dim i As Long
'
Application.ScreenUpdating = False
'
ruta = "C:\trabajo\"
Set sh = Sheets("Resumen")
hoja1 = "DATOS EMPRESA"
hoja2 = "PyG"
'
sh.Cells.Clear
arch = Dir(ruta & "*.xls*")
i = 4
'
Do While arch <> ""
On Error Resume Next
If IsError(GetObject(ruta & arch).Sheets(hoja1)) Then esta1 = False Else esta1 = True
If IsError(GetObject(ruta & arch).Sheets(hoja2)) Then esta2 = False Else esta2 = True
On Error GoTo 0
'
If esta1 Or esta2 Then
Set l2 = Workbooks.Open(ruta & arch)
If esta1 Then
sh.Range("A" & i).Value = l2.Sheets(hoja1).Range("B1").Value
sh.Range("A" & i + 1).Value = l2.Sheets(hoja1).Range("B2").Value
End If
If esta2 Then
sh.Range("A" & i + 2).Value = l2.Sheets(hoja2).Range("B28").Value
sh.Range("A" & i + 3).Value = l2.Sheets(hoja2).Range("C28").Value
sh.Range("A" & i + 4).Value = l2.Sheets(hoja2).Range("D28").Value
End If
l2.Close False
i = i + 6
End If
arch = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
Te anexo la macro con unos ajustes:
Sub Pasar_Valores()
'Por Dante Amor
'Pasar valores de varios archivos a la hoja resumen
'
Dim sh As Worksheet
Dim l2 As Workbook
Dim ruta As String
Dim arch As Variant
Dim hoja1 As String, hoja2 As String
Dim esta1 As Boolean, esta2 As Boolean
Dim i As Long
'
Application.ScreenUpdating = False
'
ruta = "C:\trabajo\"
Set sh = Sheets("Resumen")
hoja1 = "DATOS EMPRESA"
hoja2 = "PyG"
'
sh.Cells.Clear
arch = Dir(ruta & "*.xls*")
i = 2
'
Do While arch <> ""
On Error Resume Next
If IsError(GetObject(ruta & arch).Sheets(hoja1)) Then esta1 = False Else esta1 = True
If IsError(GetObject(ruta & arch).Sheets(hoja2)) Then esta2 = False Else esta2 = True
On Error GoTo 0
'
If esta1 Or esta2 Then
Set l2 = Workbooks.Open(ruta & arch)
If esta1 Then
sh.Range("A" & i & ":B" & i).Value = Application.Transpose(l2.Sheets(hoja1).Range("B1:B2").Value)
End If
If esta2 Then
sh.Range("C" & i & ":E" & i).Value = l2.Sheets(hoja2).Range("B28:D28").Value
End If
l2.Close False
i = i + 2
End If
arch = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
La macro funciona, pero cada vez que abre un libro me sale estas panatallas, seria posible que no me salieram???
Debes tener cerrados todos los libros. Solamente abre el libro con la macro.
Prueba esta:
Sub Pasar_Valores()
'Por Dante Amor
'Pasar valores de varios archivos a la hoja resumen
'
Dim sh As Worksheet
Dim l2 As Workbook
Dim ruta As String
Dim arch As Variant
Dim hoja1 As String, hoja2 As String
Dim esta1 As Boolean, esta2 As Boolean
Dim i As Long
'
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'
ruta = "C:\trabajo\"
Set sh = Sheets("Resumen")
hoja1 = "DATOS EMPRESA"
hoja2 = "PyG"
'
sh.Cells.Clear
arch = Dir(ruta & "*.xls*")
i = 2
'
Do While arch <> ""
On Error Resume Next
If IsError(GetObject(ruta & arch).Sheets(hoja1)) Then esta1 = False Else esta1 = True
If IsError(GetObject(ruta & arch).Sheets(hoja2)) Then esta2 = False Else esta2 = True
On Error GoTo 0
'
If esta1 Or esta2 Then
Set l2 = Workbooks.Open(ruta & arch, False, True)
If esta1 Then
sh.Range("A" & i & ":B" & i).Value = Application.Transpose(l2.Sheets(hoja1).Range("B1:B2").Value)
End If
If esta2 Then
sh.Range("C" & i & ":E" & i).Value = l2.Sheets(hoja2).Range("B28:D28").Value
End If
l2.Close False
i = i + 2
End If
arch = Dir()
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Fin"
End Sub
