Macro para copiar filas a otra hoja con condición
Necesito crear una macro para que me copie las filas de una hoja a otra hoja en función del valor de una celda. He intentado adaptar las macros que he visto similares por aquí pero no he sido capaz de hacerlo. Si alguien fuera tan amable de ayudarme se lo agradecería mucho.
La celda con la condición es la C1 de la hoja Datos, la hoja donde buscar Q1, columna donde buscar B4:B1500 o hasta que encuentre celda vacía, las filas a copiar son de la hoja Q1 desde A hasta N y pegarlas a partir de la celda A4 de la hoja Territorio.
1 Respuesta
Respuesta de Dante Amor
1
Te anexo la macro
Sub CopiarFilas()
'Por.Dante Amor
Set h1 = Sheets("Datos")
Set h2 = Sheets("Q1")
Set h3 = Sheets("Territorio")
'
dato = h1.[C1]
If dato = "" Then
MsgBox "Falta la condición a buscar en la hoja " & h1.Name
Exit Sub
End If
'
Set r = h2.Range("B4:B" & h2.Range("B" & Rows.Count).End(xlUp).Row)
Set b = r.Find(dato, lookat:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
Do
'detalle
u3 = h3.Range("B" & Rows.Count).End(xlUp).Row + 1
If u3 < 4 Then u3 = 4
h2.Range("A" & b.Row & ":N" & b.Row).Copy h3.Range("A" & u3)
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
MsgBox "Filas copiados"
End SubSi quieres que primero se borre la información de la hoja "territorio" y después se empiece a pegar a partir de la fila 4, entonces utiliza la siguiente macro:
Sub CopiarFilas()
'Por.Dante Amor
Set h1 = Sheets("Datos")
Set h2 = Sheets("Q1")
Set h3 = Sheets("Territorio")
'
u3 = h3.Range("B" & Rows.Count).End(xlUp).Row + 1
If u3 < 4 Then u3 = 4
h3.Range("A4:N" & u3).ClearContents
dato = h1.[C1]
If dato = "" Then
MsgBox "Falta la condición a buscar en la hoja " & h1.Name
Exit Sub
End If
'
Set r = h2.Range("B4:B" & h2.Range("B" & Rows.Count).End(xlUp).Row)
Set b = r.Find(dato, lookat:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
Do
'detalle
u3 = h3.Range("B" & Rows.Count).End(xlUp).Row + 1
If u3 < 4 Then u3 = 4
h2.Range("A" & b.Row & ":N" & b.Row).Copy h3.Range("A" & u3)
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> celda
End If
MsgBox "Filas copiados"
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
