Macro para copiar y pegar un rango de acuerdo al nombre de la celda
Debo generar una macro que me genere lo suguiente: Tengo en la columna C un encabezado "Novedad" hacia abajo un determinado número de filas que necesito copiar hasta antes de la fila que contiene "Causacion Contable" y que esta información me la copie en la siguiente hoja, esto deberá quedar una debajo de la otra y cada una con un salto de página para que cuando lo imprima me quede por hoja independiente. Esta secuencia debe repetirse durante toda la Hoja1.
Si me pudieran ayudar les agradecería inmensamente.
1 Respuesta
H o l a:
Te anexo la macro.
Si en la hoja2 quieres que aparezcan la fila que contiene el dato "Causacion Contable", cambia esta línea:
fini = b.Row + 1
Por esta línea:
fini = b.Row
Cambia en la macro el 2 en esta línea: fini = 2, por el número de fila en donde empiezan tus datos de la hoja1.
Cambia en la macro "Hoja1" y "Hoja2" por los nombres de tus hojas.
Sub CopiarUnRango()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Cells.Clear
h2.ResetAllPageBreaks
fini = 2
Set r = h1.Columns("C")
Set b = r.Find("Causacion Contable", lookat:=xlWhole)
If Not b Is Nothing Then
ncell = b.Address
Do
'detalle
ffin = b.Row - 1
h1.Rows(fini & ":" & ffin).Copy
u = h2.Range("C" & Rows.Count).End(xlUp).Row + 1
h2.Range("A" & u).PasteSpecial xlValues
u = h2.Range("C" & Rows.Count).End(xlUp).Row + 1
h2.HPageBreaks.Add Before:=h2.Cells(u, "A")
fini = b.Row + 1
Set b = r.FindNext(b)
Loop While Not b Is Nothing And b.Address <> ncell
End If
Application.ScreenUpdating = True
MsgBox "Registros copiados"
End Sub':) ':)
Hola, Muchísimas gracias
Quisiera que me ayudas con un error que me genera en la siguiente línea
h1.Rows(fini & ":" & ffin).Copy
Se ha producido el error 13 en tiempo de ejecución
Igualmente si me pudieras ayudar para que de la información que me está copiando me borre desde una fila digamos 10 hasta donde encuentra nuevamente la fila que dice novedad.
Muchas gracias!
H o l a:
Tendría que ver cómo están tus datos para analizar cuál es el problema.
Envíame tu archivo.
Macro actualizada:
Set h1 = Sheets("Reporte")
Set h2 = Sheets("Soporte")
h2.Cells.Clear
h2.ResetAllPageBreaks
For i = 1 To h1.Range("C" & Rows.Count).End(xlUp).Row
If h1.Cells(i, "C") = "Novedad" Then
fini = i
End If
If h1.Cells(i, "C") = "REGISTRO CONTABLE DE PAGO" Then
ffin = i - 1
u = h2.Range("C" & Rows.Count).End(xlUp).Row + 1
If u = 2 Then u = 1
h1.Rows(fini & ":" & ffin).Copy
h2.Range("A" & u).PasteSpecial Paste:=xlPasteAll
u = h2.Range("C" & Rows.Count).End(xlUp).Row + 1
h2.HPageBreaks.Add Before:=h2.Cells(u, "A")
End If
NextSal u dos
