Copiar Datos n hojas a hoja "Resumen"
Dam, Favor, macro excel que recorra n hojas de trabajo y de cada hoja copiar en una hoja "Resumen" lo siguiente:
Importante: Los Textos "clave" a Buscar todos se encuentran en la columna B y son : "Empresa", "Nit", "Código", "Total"
NombreHoja1: Contenido Ejemplo
B D: Columnas
Empresa-> xyz: dato(Columna D...) a la derecha del texto "Empresa", misma línea : copia 1 Dato
Nit ->123: dato(Columna D...) a la derecha del texto "Nit", misma línea : copia 1 Dato
Código
999->dato(colB) AAA(col D) BBB(Col L) 10(Col N) : copia 4 Datos ubicados en la Siguiente línea del Texto "Código"
Total-> 5 : dato(Columna N) a la derecha del texto "Total", misma línea : copia 1 Dato
NombreHoja2: Contenido Ejemplo
B D: Columnas
Empresa-> RST: datoColumna D... A la derecha del texto "Empresa", misma línea : copia 1 Dato
Nit-> 456: datoColumna D... A la derecha del texto "Nit", misma línea : copia 1 Dato
Código
111->:dato(col B) CCC:datocol D DDD:datoCol L 20:datoCol N : copia 4 Datos ubicados en la Siguiente línea del Texto "Código"
Total-> 48 : dato(Columna N) a la derecha del texto "Total", misma línea : copia 1 Dato
NombreHojaN: Contenido
...
Hoja "Resumen"
Columnas
A B C D E F G H
Fila
1 "Hoja" Empresa Nit Código Ciudad Depto Cantidad Total -----> Encabezado
2 nombrehoja1 xyz 123 999 AAA(col D...) BBB(col L...) 10(Col N) 5(col N...) ----> Datos
3 nombrehoja2 RST 456 111 CCC(col D...) DDD(col L...) 20(Col N) 48(col N...) ---> Datos
...
nombrehojaN ... ... ... ... ... ...
Hoja "Resumen"
Columnas
A B C D E F G H
Fila
1 "Hoja" Empresa Nit Código Ciudad Depto Cantidad Total -----> Encabezado
2 nombrehoja1 xyz 123 999 AAA(col D...) BBB(col L...) 10(Col N) 5(col N...) ----> Datos
3 nombrehoja2 RST 456 111 CCC(col D...) DDD(col L...) 20(Col N) 48(col N...) ---> Datos
...
nombrehojaN ... ... ... ... ... ...
1 Respuesta
Gracias
Prueba lo siguiente:
Sub Resumen()
Dim sh1 As Worksheet, sh As Worksheet
Dim fila As Long
'
Set sh1 = Sheets("Resumen")
fila = 2
For Each sh In Sheets
If sh.Name <> sh1.Name Then
sh1.Range("A" & fila).Value = sh.Name
sh1.Range("B" & fila).Value = sh.Range("D4")
sh1.Range("C" & fila).Value = sh.Range("D7")
'continúa con las siguientes filas
'
fila = fila + 1
End If
Next
End Sub[No olvides valorar.
Importante: Los Textos "clave" a Buscar todos se encuentran en la columna B y son : "Empresa", "Nit", "Código", "Total"
De acuerdo a lo anterior, prueba esto:
Sub Resumen()
Dim sh1 As Worksheet, sh As Worksheet
Dim fila As Long, col As Long, i As Long
Dim a As Variant, arr As Variant
Dim f As Range
'
arr = Array("Empresa", "D", "Nit", "D", "Código", 2, "Total", "N")
Set sh1 = Sheets("Resumen")
fila = 1
For Each sh In Sheets
col = 1
If sh.Name <> sh1.Name Then
fila = fila + 1
sh1.Cells(fila, 1).Value = sh.Name
For i = 0 To UBound(arr) Step 2
Set f = sh.Range("B:B").Find(arr(i), , xlValues, xlWhole, , , False)
If Not f Is Nothing Then
col = col + 1
If i = 4 Then
sh1.Cells(fila, col).Resize(1, 4).Value = Array(sh.Range("B" & f.Row + 1), _
sh.Range("D" & f.Row + 1), sh.Range("L" & f.Row + 1), sh.Range("N" & f.Row + 1))
col = col + 3
Else
sh1.Cells(fila, col).Value = sh.Range(arr(i + 1) & f.Row)
End If
End If
Next
End If
Next
End Sub
