Pegar información de varios libros en varias columnas
Tengo el siguiente código que saque de varias preguntas que te realizaron dante, lo que necesito es pegar la información de la columna B4 de la hoja 3 de varios libros en varias columnas del libro donde se encuentra la macro,¿podrías ayudarme?
Sub test2()
Application.ScreenUpdating = False
Dim direc, actual, ruta As String 'decalaras
actual = Application.ThisWorkbook.Name
direc = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*")
Workbooks.Open Filename:=(direc)
'Sheets("Readings (Total)").Select
ruta = ActiveWorkbook.Path
ChDir ruta
archi = dir("*.xlsx*")
Set h1 = ThisWorkbook.Sheets("Hoja4")
h1.Cells.Clear
On Error Resume Next
ffin = h1.UsedRange.Find(what:="*").Row
ActiveCell.SpecialCells(xlLastCell).Select
On Error Resume Next
Do While archi <> ""
If InStr(1, archi, actual) = 0 Then
Workbooks.Open archi
If Err.Number = 0 Then
Sheets(3).Select
Range(Range("B5"), ActiveCell.SpecialCells(xlLastCell)).Copy _
h1.Range("B" & h1.Range("A1").SpecialCells(xlLastCell).Row + 5)
End If
Err.Number = 0
Application.DisplayAlerts = False
Workbooks(archi).Close
Application.DisplayAlerts = True
End If
archi = dir()
Loop
Workbooks.Open Filename:=(direc)
ActiveWorkbook.Close SaveChanges:=False
End Sub
1 Respuesta
Necesito que la macro realice lo siguiente:
1. Seleccione un directorio donde se encontraran archivos de Excel.
2. Abrir todos los libros y copiar los datos de la hoja 3 en un rango de celdas B4 hasta donde termine (no siempre son los mismos datos). En este paso hay que copiar únicamente datos numéricos, es decir la macro debería comprobar cual es numero y cual es letra.
3. Copiar el rango anterior y pegarlo en varias columnas empezando en la columna HY celda 17 (celda HY17) de la hoja 4.
4. cerrar todas las hojas abiertas
Abro el libro1, hoja3, copio el rango B4:Bn (sólo números), y lo pego en la hoja4, celda HY17.
Abro el libro2, hoja3, copio el rango B4:¿Bn y en dónde lo pego? ¿En HZ17?
Te anexo la macro, pon la macro en un libro con la hoja4. Pon el libro en otra carpeta diferente a donde están los otros archivos.
Ejecuta la macro, selecciona la carpeta donde tienes los archivos, la macro copiará solamente los que son números.
Sub Toma_Datos()
'Por. Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Selecciona una carpeta"
.AllowMultiSelect = False
.InitialFileName = ruta
If .Show <> -1 Then Exit Sub
cp = .SelectedItems(1)
End With
'
Set h1 = ThisWorkbook.Sheets("Hoja4")
archi = Dir(cp & "\" & "*.xls*")
col = Columns("HZ").Column
Do While archi <> ""
Workbooks.Open cp & "\" & archi
j = 17
Set l2 = ActiveWorkbook
Set h2 = l2.Sheets(3)
For i = 4 To h2.Range("B" & Rows.Count).End(xlUp).Row
If IsNumeric(h2.Cells(i, "B")) Then
h1.Cells(j, col) = h2.Cells(i, "B")
j = j + 1
End If
Next
col = col + 1
l2.Close False
archi = Dir()
Loop
MsgBox "Fin"
End Sub
Sal u dos, Dante Amor, no olvides valorar la respuesta.
