Macro Copiar a otra hoja según valor de Celda
Tengo un Libro con una hoja llamada Datos con la siguiente estructura
A1 B1 C1 D1 E1 F1 G1 H1
Codigo Fecha Descripcion Marca Modelo Importe F.Venta COSTE
1 01/01/16 CLASE A 2.3 FIAT 20000 15/01/16 700
Teniendo en cuenta que hay cientos de filas y que un futuro pueda tener más columnas, necesitaría una macro que crease tantas hojas como marcas y copiase a cada una de ellas todas las filas de la misma marca respetando el formato e incluyendo la cabecera.
También agradecería una variante en el código que haga lo mismo pero en lugar de copiar toda la fila, sólo copie algunas columnas-
1 Respuesta
H o l a:
Te anexo la macro para copiar cada marca en una hoja nueva.
Sub Macro1()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("Datos")
For Each h In Sheets
Select Case h.Name
Case h1.Name
Case Else
h.Delete
End Select
Next
'
h1.Columns("D").Copy h1.Range("Z1")
u = h1.Range("Z" & Rows.Count).End(xlUp).Row
h1.Range("Z1:Z" & u).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h1.Range("Z" & Rows.Count).End(xlUp).Row
For i = 2 To u2
Set h2 = Sheets.Add(after:=Sheets(Sheets.Count))
h1.Range("A1:H" & u).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=h1.Range("Z1:Z2"), CopyToRange:=h2.Range("A1"), Unique:=False
h1.Range("Z2").Delete Shift:=xlUp
Next
h1.Range("Z:Z").Clear
Application.ScreenUpdating = True
MsgBox "Fin"
End SubEn cuanto a la variante del código para copiar solamente algunas columnas, tendría que trabajarlo. Crea una nueva pregunta para esa parte y te envío el código actualizado.
' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
Estupendo Dam, sólo un pequeño detalle que se me había pasado, las hojas han de tener el nombre de cada marca
Te anexo la macro actualizada
Sub Macro1()
'Por.Dante Amor
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set h1 = Sheets("Datos")
For Each h In Sheets
Select Case h.Name
Case h1.Name
Case Else
h.Delete
End Select
Next
'
h1.Columns("D").Copy h1.Range("Z1")
u = h1.Range("Z" & Rows.Count).End(xlUp).Row
h1.Range("Z1:Z" & u).RemoveDuplicates Columns:=1, Header:=xlYes
u2 = h1.Range("Z" & Rows.Count).End(xlUp).Row
For i = 2 To u2
Set h2 = Sheets.Add(after:=Sheets(Sheets.Count))
h2.Name = h1.Range("Z2")
h1.Range("A1:H" & u).AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=h1.Range("Z1:Z2"), CopyToRange:=h2.Range("A1"), Unique:=False
h1.Range("Z2").Delete Shift:=xlUp
Next
h1.Range("Z:Z").Clear
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub' : ) 'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias ' : )
Al final de mi respuesta hay 2 valoraciones, "Votar" y "Excelente", si todavía tienes dudas puedes solicitar más información, si la respuesta cumple con lo primero que solicitaste, esperaría que cambiaras la valoración.
E stimado, al final de mi respuesta hay dos opciones para valorar "Votar" y "Excelente", si todavía tienes dudas puedes solicitar más información; si la respuesta tiene lo que solicitaste en un principio esperaría que cambiaras la valoración.
excelente! - Daniel Conde