Filtros en archivo nuevo
Hola Dam necesito su ayuda necesito una macro que en la columna A filtre los datos , y por cada dato igual me cree un archivo y pase todas las columnas. Explicado de otra forma es como si yo aplicara un filtro por un criterio de la columna A, y todos los registros resultantes incluidos la columna A me los copie en um archivo nuevo. Ejemplo
A B C D E F G H I J ........AA
1021 X Y C D X X X X X ..........X
1022
1021
1022
1023
1023
ETC
Para este ejemplo crearía archivos uno con todos los registros de 1021 y otro con todos los registros d 1022, otros con 1023 y así sucesivamente.
Muchas gracias por su ayuda.
1 Respuesta
Te anexo la macro, cambia en esta línea, el nombre de "promotor2", por el nombre de tu libro que contiene los datos y también cambia el nombre dela "Hoja1". Por el nombre de tu hoja.
Set h1 = Workbooks("promotor2").Sheets("Hoja1")
Sub dividir()
'por.dam
Set h1 = Workbooks("promotor2").Sheets("Hoja1")
ufila = ActiveCell.SpecialCells(xlLastCell).Row
ucol = ActiveCell.SpecialCells(xlLastCell).Column
Range(Cells(1, 1), Cells(ufila, ucol)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ini = 1
j = 1
promant = Cells(ini, "A")
Workbooks.Add
wb = ActiveWorkbook.Name
Set hb = Workbooks(wb)
ws = ActiveSheet.Name
Set h2 = hb.Sheets(ws)
h1.Activate
For i = ini To h1.Range("A" & Rows.Count).End(xlUp).Row
promnvo = Cells(i, "A")
If promant = promnvo Then
h1.Range(Cells(i, "A"), Cells(i, ucol)).Copy Destination:= _
h2.Cells(j, "A")
j = j + 1
Else
Workbooks.Add
wb = ActiveWorkbook.Name
Set hb = Workbooks(wb)
ws = ActiveSheet.Name
Set h2 = hb.Sheets(ws)
j = 1
h1.Activate
h1.Range(Cells(i, "A"), Cells(i, ucol)).Copy Destination:= _
h2.Cells(j, "A")
j = j + 1
End If
promant = promnvo
Next
MsgBox "Fin del proceso"
End Sub Saludos.Dam
Si es lo que necesitas.
Dam muchas gracias, si eso era, solo una cosa es que me crea un libro como encabezado, pero en los demás archivos no coloca el encabezado. Se puede modificar para que en cada archivo escriba el encabezado. esta en la fila 1, y no lo separe como archivo.
gracias.
No le puse encabezados porque en tu ejemplo no los tenía y tampoco lo mencionaste. Lo que está haciendo la macro es considerar la primer fila como otro registro por eso le crea su propio archivo.
Te cambio la macro.
Sub dividir()
'por.dam
Set h1 = Workbooks("promotor2").Sheets("Hoja1")
ufila = ActiveCell.SpecialCells(xlLastCell).Row
ucol = ActiveCell.SpecialCells(xlLastCell).Column
Range(Cells(1, 1), Cells(ufila, ucol)).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
ini = 2
j = 1
promant = Cells(ini, "A")
Workbooks.Add
wb = ActiveWorkbook.Name
Set hb = Workbooks(wb)
ws = ActiveSheet.Name
Set h2 = hb.Sheets(ws)
h1.Activate
h1.Rows(1).Copy Destination:=h2.Range("A1")
j = j + 1
For i = ini To h1.Range("A" & Rows.Count).End(xlUp).Row
promnvo = Cells(i, "A")
If promant = promnvo Then
h1.Range(Cells(i, "A"), Cells(i, ucol)).Copy Destination:= _
h2.Cells(j, "A")
j = j + 1
Else
Workbooks.Add
wb = ActiveWorkbook.Name
Set hb = Workbooks(wb)
ws = ActiveSheet.Name
Set h2 = hb.Sheets(ws)
j = 1
h1.Activate
h1.Rows(1).Copy Destination:=h2.Range("A1")
j = j + 1
h1.Range(Cells(i, "A"), Cells(i, ucol)).Copy Destination:= _
h2.Cells(j, "A")
j = j + 1
End If
promant = promnvo
Next
MsgBox "Fin del proceso"
End SubSaludos.Dam
