Macro para crear hojas con un nombre y copiar datos en ellas.

Necesito hacer una macro que copie datos e inserte hojas nuevas, apartir de la "Hoja1".

En la "Hoja1" tengo una tabla de 14 columnas y 100 filas, La copia se debe de realizar según datos de la columna "A".

Al ejecutar la macro, se buscan datos en la columna "A" a partir de la fila "4", (las filas 1, 2 y 3 son la cabecera).

Por cada dato distinto de dicha columna, creará una hoja y la pondrá el nombre de ese dato. En ella copiará de la tabla de la "Hoja1": Filas 1, 2 y 3, y despues todas las filas cuyos datos de la columna "A" sean iguales.

Ejemplo:

Celda (A,4) = FORD

Celda (A,5) = KIA

Celda (A,6) = FORD

Celda (A,10) = NISSAN

Al ejecutar la macro:

Se crea una hoja con nombre FORD, y copia de la "Hoja1", las filas 1, 2, 3, 4 y 6.

Se crea una hoja con nombre KIA, y copia de la "Hoja1", las filas 1, 2, 3 y 5.

Se crea una hoja con nombre NISSAN, y copia de la "Hoja1", las filas 1, 2, 3 y 10.

Respuesta
2

Te anexo la macro

Sub CrearyCopiar()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    For i = 4 To h1.Range("A" & Rows.Count).End(xlUp).Row
        existe = False
        For Each h2 In Sheets
            If h2.Name = h1.Cells(i, "A") Then
                existe = True
                Exit For
            End If
        Next
        If existe Then
            u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
            h1.Rows(i).Copy h2.Rows(u)
        Else
            Set h3 = Sheets.Add(after:=Sheets(Sheets.Count))
            hoja = h1.Cells(i, "A")
            h3.Name = h1.Cells(i, "A")
            h1.Rows(1 & ":" & 3).Copy h3.Range("A1")
            h1.Rows(i).Copy h3.Rows(4)
        End If
    Next
End Sub

Saludos.Dante Amor

Si es lo que necesitas. No olvides valorar la respuesta.

Hola. Gracias por la rápida respuesta.

Al ejecutar la macro me sale un error: "Subíndice fuera del intervalo".

¿Que debería modificar?

Saludos,

¿La hoja donde tienes los datos se llama "Hoja1"?

En la ventana que te aparece el error, presiona el botón "Depurar" y dime qué línea de la macro se pone en amarillo.

Tienes algún nombre que tenga caracteres como  / \ " ,  :

Ya que esos caracteres no se puedes nombrar una hoja

¿O tienes nombres con una longitud de caracteres mayor a 30?

Hola.

Perdona, tienes razón, el fallo estaba en la nomenclatura de la hoja.

La macro funciona a la perfección, lo único, sale el error "400", cuando entre medias encuentra una celda en blanco en la columna "A".

Si se pede corregir mejor, sino no importa porque la macro se ejecuta igual.

Muchas gracias y espero tu respuesta.

Saludos,

Prueba con la siguiente

Sub CrearyCopiar()
'Por.Dante Amor
    Application.ScreenUpdating = False
    Set h1 = Sheets("Hoja1")
    For i = 4 To h1.Range("A" & Rows.Count).End(xlUp).Row
        If h1.Cells(i, "A") <> "" Then
            existe = False
            For Each h2 In Sheets
                If h2.Name = h1.Cells(i, "A") Then
                    existe = True
                    Exit For
                End If
            Next
            If existe Then
                u = h2.Range("A" & Rows.Count).End(xlUp).Row + 1
                h1.Rows(i).Copy h2.Rows(u)
            Else
                Set h3 = Sheets.Add(after:=Sheets(Sheets.Count))
                hoja = h1.Cells(i, "A")
                h3.Name = h1.Cells(i, "A")
                h1.Rows(1 & ":" & 3).Copy h3.Range("A1")
                h1.Rows(i).Copy h3.Rows(4)
            End If
        End If
    Next
End Sub

Saludos.Dante Amor

No olvides valorar la respuesta.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas