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.
1 respuesta
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 SubSaludos.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 SubSaludos.Dante Amor
No olvides valorar la respuesta.
