Macro crear hojas dependiendo información de una columna
Tengo una base de datos en una hoja la cual genero con frecuencia y el número de registros puede variar,
La base de tatos contiene información desde la columna “A” hasta la columna “S”
Desde la fila “1” hasta la fila “n…”
En la columna “P” solo existen cuatro tipos de opciones (Blanco), (negro), (verde) y (amarillo). Necesito su ayuda a fin de crear una macro que me perita crear hojas de cálculo con los nombres la información de la columna "P" y a la vez me copie toda la información de la fila.
Ejemplo
En la hoja “Blanco” copie todos registros de las filas 1,2,3,4,5,6,7,8, n….. Si en la Columna “P” de la fila contiene la opción “blanco”
En la hoja “Negro” copie todos registros de las filas 1,2,3,4,5,6,7,8, n….. Si en la Columna “P” de la fila contiene la opción “negro”
En la hoja “verde” copie todos registros de las filas 1,2,3,4,5,6,7,8, n….. Si en la Columna “P” de la fila contiene la opción “verde”
En la hoja “amarillo” copie todos registros de las filas 1,2,3,4,5,6,7,8, n….. Si en la Columna “P” de la fila contiene la opción “amarillo”
CONDICIONES
- Para el trabajo el macro o bien puede cortar y pegar y dejar la hoja original en blanco, o bien puede solo copiar y mantener la hoja original como base de datos
- Los registros en las nuevas hojas debe estar a partir de la fila 4
1 Respuesta
Ejecuta la siguiente macro en la hoja donde tienes tus colores.
Sub CopiarColores()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = ActiveSheet
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
[A1].AutoFilter
Columns("A:S").AutoFilter
u = Range("P" & Rows.Count).End(xlUp).Row
cs = Array("blanco", "negro", "verde", "amarillo")
For i = LBound(cs) To UBound(cs)
existe = False
h1.Range("A1:S" & u).AutoFilter Field:=16, Criteria1:=cs(i)
u = h1.Range("P" & Rows.Count).End(xlUp).Row
If u > 1 Then
For Each h In Sheets
If h.Name = cs(i) Then
existe = True
Exit For
End If
Next
If existe = False Then
Set h2 = Sheets.Add(after:=Sheets(Sheets.Count))
h2.Name = cs(i)
Else
h = cs(i)
Set h2 = Sheets(h)
h2.Cells.Clear
End If
h1.Range("A2:S" & u).Copy
h2.Range("A4").PasteSpecial Paste:=xlPasteValues
End If
Next
h1.Rows("1:1").Delete
Application.ScreenUpdating = True
MsgBox "Terminado"
End SubLa hoja mantendrá original como base datos.
Saludos. Dante Amor
¡Gracias! Estupendo, funciono a la perfección
Estimado experto Dante
El macro me funciono a la perfección, sin embargo agradeceré su ayuda para hacer unas correcciones no indicadas en la primera ocasión.
El macro me corre perfecto, sin embargo cada vez que lo hecho andar me borra los encabezados, de las Hojas (BLANCO, NEGRO, VERDE y AMARAILLO).
Hay alguna forma de que no lo haga? Pues es como si cada vez que lo hecho andar crea nuevas hojas y borra los encabezados.
Si se modifica el macro y con el mismo filtro “P” con las mismas condiciones se hace que haga las misma labor pero pegue la información en hojas ya existentes “Blanco” “Negro” “verde” y “amarillo”
Pero quieres que pegue la información a partir de la fila 4, ¿o qué la pegue debajo de la información que ya existe?
Estimado Dante
necesito que pegue a partir de la fila cuatro, fila 1 a 3 son encabezado.
Utiliza esta macro:
Sub CopiarColores()
'Por.Dante Amor
Application.ScreenUpdating = False
Set h1 = ActiveSheet
Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
[A1].AutoFilter
Columns("A:S").AutoFilter
u = Range("P" & Rows.Count).End(xlUp).Row
cs = Array("blanco", "negro", "verde", "amarillo")
For i = LBound(cs) To UBound(cs)
existe = False
h1.Range("A1:S" & u).AutoFilter Field:=16, Criteria1:=cs(i)
u = h1.Range("P" & Rows.Count).End(xlUp).Row
If u > 1 Then
For Each h In Sheets
If h.Name = cs(i) Then
existe = True
Exit For
End If
Next
If existe = False Then
Set h2 = Sheets.Add(after:=Sheets(Sheets.Count))
h2.Name = cs(i)
Else
h = cs(i)
Set h2 = Sheets(h)
u2 = h2.Range("P" & Rows.Count).End(xlUp).Row
If u2 < 4 Then u2 = 4
h2.Range("A4:S" & u2).ClearContents
End If
h1.Range("A2:S" & u).Copy
h2.Range("A4").PasteSpecial Paste:=xlAll
End If
Next
h1.Rows("1:1").Delete
Application.ScreenUpdating = True
MsgBox "Terminado"
End Sub
