Copiar una página y cambiarle el nombre usando un rango
Tengo una página que quiero copiar y cambiarle el nombre.
El nombre se encuentra en un rango.
Por cada celda, copiar y asignar el nombre que tiene la celda
El rango contiene un listado de personas y quiero crear una hoja nueva por cada persona.
Suponiendo que tienes tu lista en la celda A1 y el rango esta hacia abajo esta es la macro que ocupas, si tiene encabezado la lista quítaselo sino también te creara un hoja en la imagen de abajo veres el resultado de la macro
Sub crear_hoja()
Set datos = Range("a1").CurrentRegion
With datos
For I = 1 To .Rows.Count
nombre = .Cells(I, 1)
Sheets.Add(After:=Sheets(Sheets.Count)).Name = nombre
Next I
End With
Set datos = Nothing
End Sub
¡Gracias! Me devuelve el error 1004 en tiempo de ejecución
Es porque ya existe una o varias páginas con el nombre que esta leyendo de la lista, esta es la macro corregida, esta macro ignora ese error y sigue con la lista.
Sub crear_hoja()
Application.DisplayAlerts = False
Set datos = Range("a1").CurrentRegion
With datos
For I = 1 To .Rows.Count
nombre = .Cells(I, 1)
On Error Resume Next
Sheets.Add(After:=Sheets(Sheets.Count)).Name = nombre
If Err.Number > 0 Then
ActiveSheet.Delete
End If
On Error GoTo 0
Next I
End With
Set datos = Nothing
Application.DisplayAlerts = True
End Sub
Gracias, pero necesito copiar la hoja, no agregar nueva
Tu petición inicial fue
El rango contiene un listado de personas y quiero crear una hoja nueva por cada persona. No mencionaste nada de copiar, la macro hace las dos cosas valida que la hoja exista, si existe te crea una copia exactamente igual a donde tienes el listado, sino crea la hoja y copia la información formatos, fórmulas todo pasa exactamente como esta.
Sub crear_copiar()
Set h1 = Worksheets("hoja1")
Set datos = h1.Range("a1").CurrentRegion
With datos
For I = 1 To .Rows.Count
nombre = .Cells(I, 1): buscarhoja = False
On Error Resume Next
buscarhoja = (Worksheets(nombre).Name <> "")
existe = buscarhoja
On Error GoTo 0
If existe Then
copia:
Set destino = Worksheets(nombre)
h1.Cells.Copy: destino.Range("a1").PasteSpecial xlPasteAllUsingSourceTheme
Else
Sheets.Add(After:=Sheets(Sheets.Count)).Name = nombre
GoTo copia
End If
Next I
End With
h1.Select
Set datos = Nothing
End Sub
