Macro que copie nombre de hoja (origen) a nueva hoja(creada), y su encabezado (rango de celdas)
Hola, buenos días:
Bien, sigo siendo novata aunque ya he resuelto uno que otro problemilla por mi misma pero sigo batallando con algunas cosillas como la que les planteo en seguida:
Tengo mi macro actual, la cual funciona copiando las filas rellenas de las hojas en nuevas hojas, eso lo hace de maravilla, pero lo que me falla es que la nueva hoja con las filas rellenas se llame de la misma forma que la de origen (de donde se obtuvieron las filas rellenas) además de copiar el encabezado de cada hoja (rango "A1:A5" - "O1:O6") que se ubique por arriba de las filas que actualmente la macro copia en la hoja nueva. Ojalá me puedan ayudar u orientar!. Anexo la macro con la cual estoy trabajando. Desde ya, muchas gracias.
Sub copiafilarellena()
For Each sh In ActiveWorkbook.Sheets
'selecciono la hoja
sh.Select
'puedo omitir hoja
If sh.Name <> "Sheet3" Then
Application.ScreenUpdating = False
On Error Resume Next
Set h1 = ActiveSheet
Set h2 = Sheets.Add
'ActiveSheet.Name = Nuevo_Nombre
h1.Select
ini = "A"
fin = "O"
For i = 2 To h1.Range(ini & Rows.Count).End(xlUp).Row
si = 0
For j = 1 To Range(fin & 1).Column
Cells(i, j).Select
If Cells(i, j).Interior.ColorIndex = 6 Or Cells(i, j).Interior.ColorIndex = 27 Then
si = 1
Else
si = 0
End If
Next
If si = 1 Then
Range(ini & i & ":" & fin & i).Select
h1.Range(ini & i & ":" & fin & i).Copy h2.Range(ini & h2.Range(ini & Rows.Count).End(xlUp).Row + 1)
Selection.Delete Shift:=xlUp
i = i - 1
End If
Next
End If
'pasa a la hoja siguiente
Next sh
Application.ScreenUpdating = True
End Sub