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.

1

1 respuesta

Respuesta
1

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

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas