Macro para abrir varios archivos de Excel de diferentes carpetas y copiar la información de cada uno, en un mismo libro maestro.
Tengo una carpeta maestra, donde tengo "n" cantidad de subcarpetas, estas contienen a su vez, archivos pdf, dwg, pero los que me interesan son los archivos de excel, necesito abrir estos archivos y copiar toda la información de cada una de ellos en un mismo libro maestro. Esta información es similar en cantidad de columnas, varia en el tipo de información que contiene cada celda y en la cantidad de filas, pero están acomodadas dentro del mismo formato. Estos pueden llegar a ser hasta 15 mil líneas o más...
Una vez que termine de copiar el contenido de todos los libros en el libro maestro de excel, la macro lea la columna H y reconozca fila por fila, 1 por 1, si se repite la información, en caso que coincida (supongamos la celda H10 y H11 ) compare la información de la columna J de estas mismas filas(J10 y J11), en ella se encontraran revisiones (0, 1, 2, 3 ... RZ) y deje únicamente la ultima revisión, eliminando las otras filas. Ejemplo:
Columna H Columna J
10 A7714-AB-STR-0053-001 1
11 A7714-AB-STR-0053-001 2
12 A7714-AB-STR-0053-001 3
La macro deberá reconocer que las filas 10, 11 y 12 tienen el mismo contenido en la columna H, pero difieren en la columna J, eliminara las filas 10 y 11, dejando únicamente el valor más alto.
Los valores de la columna J van de cero ( 0 ) hasta RZ, que es lo más alto. ( ejemp. 0-1-2-3-4-5...RZ).
Espero haberme dado a entender y cualquier duda o comentario, estoy a sus ordenes. También les puedo enviar el archivo, de ser necesario.
2 respuestas
La primer parte de abrir y copiar lo puedes hacer de esta manera;
Sub Open_Files()
Dim r&, s&
Dim b As Workbook
Dim Hoja As Object
Application.ScreenUpdating = False
'Definir la variable como tipo Variante
Dim X As Variant
'Abrir cuadro de dialogo
X = Application.GetOpenFilename _
("Excel Files (*.xlsx), *.xlsx", 2, "Abrir archivos", , True)
'Validar si se seleccionaron archivos
If IsArray(X) Then ' Si se seleccionan
'Crea Libro nuevo
'*/********************
For y = LBound(X) To UBound(X)
Application.StatusBar = "Importando Archivos: " & X(y)
r = ThisWorkbook.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
Set b = Workbooks.Open(X(y))
s = b.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
b.Sheets(1).Range("A2:F" & s).Copy
ThisWorkbook.Sheets(1).Range("A" & r + 1).Paste
b.Close False
Next
Application.StatusBar = "Listo"
End If
Application.ScreenUpdating = False
End Sub