TOP
Macro de araña para recopilar datos de varios archivos Excel
Descripción
En este artículo, consideraremos un ejemplo de una macro que puede buscar datos en muchos libros y registrar la información seleccionada en un archivo de informe separado.
Para hacer esto, abra su libro, vaya a Visual Basic Editor (Alt+F11) , agregar un nuevo módulo en blanco (Insert - Module) y copie este texto de macro allí:
- Sub Report_file()
-
- Application.ScreenUpdating = False
-
- Set report = Workbooks("Report.xlsb").Worksheets(1)
- find_field = report.[a1]
-
-
- FilesToOpen = Application.GetOpenFilename _
- (FileFilter:="All files (*.*), *.*", _
- MultiSelect:=True, Title:=" ¡Selecciona archivos! ")
-
- If TypeName(FilesToOpen) = "Boolean" Then
- MsgBox " ¡Ningún archivo seleccionado! "
- Exit Sub
- End If
-
-
- m = 1
- While m <= UBound(FilesToOpen)
- Set importWB = Workbooks.Open(Filename:=FilesToOpen(m))
- Set importWS = importWB.Worksheets(1)
-
-
- For Each cell2 In report.Range(report.Cells(1, 2), report.Cells(1, report.UsedRange.Columns.Count))
- On Error Resume Next: Err.Clear
-
- tr = importWS.UsedRange.Find(find_field).Row
- tc = importWS.UsedRange.Find(find_field).Column
- x = importWS.Range(importWS.Cells(tr, tc), importWS.Cells(20000, tc)).Find(report.Cells(m + 1, 1).Value).Row
- y = importWS.UsedRange.Find(cell2.Value).Column
-
- report.Cells(m + 1, cell2.Column).Value = importWS.Cells(x, y).Value
- Next
-
- importWB.Close savechanges:=False
- m = m + 1
- Wend
-
- Application.ScreenUpdating = True
- End Sub
Sub Report_file()
'moonexcel.com.ua
Application.ScreenUpdating = False ' desactivar la actualización de pantalla
Set report = Workbooks("Report.xlsb").Worksheets(1)
find_field = report.[a1]
' abrir el cuadro de diálogo para seleccionar archivos para importar
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="All files (*.*), *.*", _
MultiSelect:=True, Title:=" ¡Selecciona archivos! ")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox " ¡Ningún archivo seleccionado! "
Exit Sub
End If
' revisamos todos los archivos seleccionados uno por uno
m = 1
While m <= UBound(FilesToOpen)
Set importWB = Workbooks.Open(Filename:=FilesToOpen(m))
Set importWS = importWB.Worksheets(1)
' vencimos a las células" sombreros "
For Each cell2 In report.Range(report.Cells(1, 2), report.Cells(1, report.UsedRange.Columns.Count))
On Error Resume Next: Err.Clear
' buscando significado en un libro abierto
tr = importWS.UsedRange.Find(find_field).Row
tc = importWS.UsedRange.Find(find_field).Column
x = importWS.Range(importWS.Cells(tr, tc), importWS.Cells(20000, tc)).Find(report.Cells(m + 1, 1).Value).Row
y = importWS.UsedRange.Find(cell2.Value).Column
' transferir los valores encontrados al archivo de informe
report.Cells(m + 1, cell2.Column).Value = importWS.Cells(x, y).Value
Next
importWB.Close savechanges:=False
m = m + 1
Wend
Application.ScreenUpdating = True
End Sub
Después de eso, puedes regresar a Excel y ejecutar nuestra macro a través del menú. Tools - Macro - Macros (Alt+F8) .