Macro que busca en varias hojas y copia determinadas filas en otra hoja
Tengo que arreglar una macro para que busque en las hojas que se llaman D1, D2, D3... Si en las columnas S y T tienen el dato "NO", de encontrarse ese dato, debe copiar la fila completa A:W en la hoja "Informe" en la siguiente fila vacía que ubique. Dado que en cada ejecución de la Macro borra el contenido dejando únicamente los títulos para la nueva carga.
Les dejo como me quedo luego de hacer y deshacer:
Private Sub CommandButton21_Click()
Dim WS As Worksheet
Dim rBingo As Range
Set ori1 = Sheets("D1")
Set ori2 = Sheets("D2")
Set ori3 = Sheets("D3")
Set ori4 = Sheets("D4")
Set ori5 = Sheets("D5")
Set ori6 = Sheets("D6")
Set ori7 = Sheets("D7")
Set ori8 = Sheets("D8")
Set ori9 = Sheets("D9")
Set ori10 = Sheets("D10")
Set ori11 = Sheets("D11")
Set ori12 = Sheets("D12")
Set ori13 = Sheets("D13")
Set ori14 = Sheets("D14")
Set ori15 = Sheets("D15")
Set des = Sheets("Informe")
Borrar_Informe
For i = 20 To ori1.Range("T" & Rows.Count).End(xlUp).Row
encontrado = "SI"
If ori1.Cells(i, "T") = "NO" Then
For j = 20 To des.Range("T" & Rows.Count).End(xlUp).Row
If encontrado = "SI" Then
ori1.Cells(i, "T").Copy Destination:=des.Range("A" & des.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next
End If
Next
End Sub
Sub Borrar_Informe()
Dim rCell As Range
Set rCell = Range("A3:W150")
Do While Not IsEmpty(ActiveCell)
rCell.Offset(0, 0).Value = " "
Set rCell = rCell.Offset(0, 0)
Exit Do
Loop
End Sub
1 Respuesta
Hay un par de puntos que no se comprenden, por ej la subrutina BorrarInforme.
¿Qué intentas: borrar las celdas del rango? Con Offset(0,0) no avanzas ni filas ni col... por lo tanto siempre estas en el mismo lugar.
Si intentas limpiar ese rango podrías usar esto:
Range("A3:W150")=""
Y si intentas borrar solo ciertas celdas del rango evaluando cierta condición podrías usar esta donde solo se borra si el valor es <> 1:
Sub Borrar_Informe()
Dim cd
For Each cd In Range("A3:W150")
If cd.Value <> 1 Then cd.Value = ""
Next
End Sub
La otra macro te la dejo comentada para que puedas avanzar sola, sino comenta si lo ejecutado está bien y cómo seguir con las restantes hojas.
Gracias Elsa, te comento que borrar_Informe funciona perfecto así, me borra el rango A3:W150 directamente.
En lo que me trabe es en el recorrido de las hojas desde D1 a D31 buscando en las columnas T y S el dato NO, para copiar esas filas completa en la hoja Informe, una a continuación de otra sin dejar filas en blanco.
No puede combinar correctamente las funciones de buscar y si encuentra copy/paste, por eso pido ayuda.
Desde ya muchas gracias.
Ah, qué pena, no se que paso con el código que te dejé (o intenté dejar) pegado...
Bien, aquí va de nuevo:
Private Sub CommandButton21_Click()
'comentada y ajustada por Elsamatilde
Dim WS As Worksheet
Dim rBingo As Range
Set des = Sheets("Informe")
Dim i As Integer, x As Integer
Dim ho, hoj
Borrar_Informe 'revisar
'proceso principal para las 15 hojas
For x = 1 To 15
ho = "D" & x
Set hoj = Sheets(ho)
'la que indica el fin de rango es col T
For i = 20 To hoj.Range("T" & Rows.Count).End(xlUp).Row
'si cunple las 2 condiciones se copia en destino
If hoj.Cells(i, "S") = "NO" And hoj.Cells(i, "T") = "NO" Then
hoj.Range("A" & i & ":W" & i).Copy Destination:=des.Range("A" & des.Range("A" & Rows.Count).End(xlUp).Row + 1)
End If
Next i
'repetir para las otras hojas
Next x
End Sub
Con respecto a la macro BorrarInforme no digo que esté mal solo intenté dejarte una propuesta mejorada. Offset(0,0) no tiene ningún sentido de estar... no te moves ni fila ni col entonces podes aligerar el código retirandolo.
Sdos!
