Capturar información de varias hojas en una nueva

Estoy tratando de automatizar la captura de información a partir de varias hojas de un mismo libro de excel, una vez grabada la macro esta solo me efectúa el proceso hasta la hoja 4 del libro y en total son 287 hojas.

Que sentencia debo incluir al código para iterar el proceso hasta la ultima hoja.?

Gracias!

Este es el código actual:

Sub pestanas()
'
' Pestanas Macro
'
'
Sheets("Hallazgo1").Select
Range("G5:R5").Select
Selection.Copy
Sheets("Hoja1").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Hallazgo2").Select
Range("G5:R5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hoja1").Select
Range("A3").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Hallazgo3").Select
Range("G5:R5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hoja1").Select
Range("A4").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Sheets("Hallazgo4").Select
ActiveWindow.ScrollRow = 11
ActiveWindow.ScrollRow = 9
ActiveWindow.ScrollRow = 8
ActiveWindow.ScrollRow = 7
ActiveWindow.ScrollRow = 6
ActiveWindow.ScrollRow = 5
ActiveWindow.ScrollRow = 4
ActiveWindow.ScrollRow = 3
ActiveWindow.ScrollRow = 1
Range("G5:R5").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Hoja1").Select
Range("A5").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("E15").Select
End Sub

Respuesta
2

Te adjunto la macro para conseguirlo:

sub proceso()
'por luismondelo
for each hoja in sheets
if ucase(hoja.name) <>"HOJA1" then
hoja.select
range("g5:r5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
end if
next
end sub

recuerda valorar la respuesta

Hola!

Gracias por la pronta respuesta. La macro se ha ejecutado pero no hasta el final supongo que los rangos de algunas de las hojas son diferentes y por tanto no pudo capturar aquellos datos fuera del rango g5:r5. Tienes alguna Recomendación Para este problema.?

La macro está preparada para recorrer todas las hojas del libro. ¿Pudiera ser que tuvieras alguna pestaña oculta?

¿Puede ser que algunas celdas estén combinadas?

Buen Día!!

Si, Debo preparar la data para ejecutar el proceso sin inconvenientes, gracias por las sugerencias. 

Qué sintaxys debo agregar al código para que me repita el proceso y capture informacion en la columna b, c, d....n

Hola!

Ya he solucionado la pregunta anterior solo era copiar la misma línea y cambiar la columna de destino...

Ahora quisiera saber si es posible meter un "or" en el rango de captura es decir me encuentro que los datos están en el rango g5:r5 y en ocasiones en el rango h5:r5

Prueba con la macro así:

sub proceso()
'por luismondelo
for each hoja in sheets
if ucase(hoja.name) <>"HOJA1" then
hoja.select
if range("h5").value <>"" then
range("h5:h5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
else
range("g5:r5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
end if
next
end sub

¡Gracias! 

Buen día Luis!

Mira me he encontrado con que algunos de los rangos están vacíos y deseo que para estas casillas vacías me muestre que no registra "N.R" ... intenté (basada en tu código) agregándole un if, pero no me ha resultado:

sub proceso()
'por luismondelo
for each hoja in sheets
if ucase(hoja.name) <>"HOJA1" then
hoja.select
if range("h5").value <>"" then
range("h5:h5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
else
if range("h5").value ="" then
print 'N.R'
else
range("g5:r5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
end if
next
end sub

¿Dónde quieres pintar esas siglas?

Hola!

En la misma columna a. Sucede que al correr la iteración; si encuentra un rango sin información, este no me reporta que aquel rango de esa hoja no tiene datos o está en blanco...

Gracias Mil!

("a65000")

Prueba ahora con este código para el tema de los rangos vacios

sub proceso()
'por luismondelo
c=0
for each hoja in sheets
if ucase(hoja.name) <>"HOJA1" then
hoja.select
if range("h5").value <>"" then
range("h5:h5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
c=1
end if
if range("g5").value <>"" then
range("g5:r5").copy
sheets("hoja1").range("a65000").end(xlup).offset(1,0).pastespecial paste:=xlvalues
c=1
end if
if c=0 then
sheets("hoja1").range("a65000").end(xlup).offset(1,0).value = "N.R"
end if
end if
c=0
next
end sub

Buen Día. Muchas Gracias por tu colaboración!!

Probé la opción de código anterior pero se duplicaron los registros. Encontré una función "IsEmpty"  pero no sé como adaptarla al código. Esto va así:

Sub Extraccion()
'
' Extraccion Macro
'
'
For Each hoja In Sheets
If UCase(hoja.Name) <> "HOJA1" Then
hoja.Select
If Range("h5").Value <> "" Then
Range("h5:r5").Copy
Sheets("hoja1").Range("a65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("h5:u5").Copy
Sheets("hoja1").Range("a65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("h6").Value <> "" Then
Range("h6:j6").Copy
Sheets("hoja1").Range("b65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("h6:m6").Copy
Sheets("hoja1").Range("b65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("h7").Value <> "" Then
Range("h7:j7").Copy
Sheets("hoja1").Range("c65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("h7:m7").Copy
Sheets("hoja1").Range("c65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("q6").Value <> "" Then
Range("q6:u6").Copy
Sheets("hoja1").Range("d65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("n6:r6").Copy
Sheets("hoja1").Range("d65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("q7").Value <> "" Then
Range("q7:u7").Copy
Sheets("hoja1").Range("e65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("n7:r7").Copy
Sheets("hoja1").Range("e65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("w6").Value <> "" Then
Range("w6:z6").Copy
Sheets("hoja1").Range("f65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("z6:ac6").Copy
Sheets("hoja1").Range("f65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("w7").Value <> "" Then
Range("w7:z7").Copy
Sheets("hoja1").Range("g65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("z7:ac7").Copy
Sheets("hoja1").Range("g65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("ag6").Value <> "" Then
Range("ag6:ai6").Copy
Sheets("hoja1").Range("h65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("ad6:af6").Copy
Sheets("hoja1").Range("h65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("ag7").Value <> "" Then
Range("ag7:ai7").Copy
Sheets("hoja1").Range("i65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("ad7:af7").Copy
Sheets("hoja1").Range("i65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
If Range("v4").Value <> "" Then
Range("v4:af4").Copy
Sheets("hoja1").Range("j65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
If Range("aa4").Value <> "" Then
Range("aa4:ai4").Copy
Sheets("hoja1").Range("j65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("y4:ai4").Copy
Sheets("hoja1").Range("j65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
End If
If Range("b10").Value <> "" Then
Range("b10:ai10").Copy
Sheets("hoja1").Range("k65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
Else
Range("b12:af12").Copy
Sheets("hoja1").Range("k65000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlValues
End If
End If
Next
End Sub

La función isempty es lo mismo que lo que he hecho yo con la línea

<>""

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas