Generar varios archivos a partir de uno
Tengo un archivo con datos transacciones de clientes (varios) y la idea es generar un archivo xls para cada uno con todas sus transacciones.
El archivo tiene 4 columnas
columna A = fecha
columna B = cod cliente
columna C = nº transc.
columna D = importe
Cada cliente realiza de 1 a n transacciones y la idea es que se genere un archivo xls cada vez que el cod cliente cambie (la tabla está ordenada por cod cliente), entonces si las primeras 10 filas son del cliente 7896-9 entonces que tome esas 10 filas y cree un archivo 7896-9.xls y así sucesivamente con el resto de clientes. Un cliente puede tener 1 o más transacciones. Ojalá me puedas ayudar.
El archivo tiene 4 columnas
columna A = fecha
columna B = cod cliente
columna C = nº transc.
columna D = importe
Cada cliente realiza de 1 a n transacciones y la idea es que se genere un archivo xls cada vez que el cod cliente cambie (la tabla está ordenada por cod cliente), entonces si las primeras 10 filas son del cliente 7896-9 entonces que tome esas 10 filas y cree un archivo 7896-9.xls y así sucesivamente con el resto de clientes. Un cliente puede tener 1 o más transacciones. Ojalá me puedas ayudar.
2 Respuestas
Respuesta de fejoal
1
OK, hice el procedimiento aunque me parece extraño que ante cada cambio hayaque generar todos los archivos de nuevo.
El procedimiento siguiente aplica un filtro sobre la base y en función de la lista de clientes (códigos) selecciona registros, abre libro nuevo, copia y los pega en él. Finalmente graba y cierra el archivo.
Ya sabes, abre el Editor de VBA y pega este código en un módulo nuevo:
Sub GenTodos()
' xgoro, indica dónde se guardarán los archivos
Donde = "C:\Mis documentos\"
' xgoro, indica celda donde está el primer código de cliente
Celda = "A4"
'------------- gracias!
'Application.ScreenUpdating = False ' si quieres evitar los movimientos de pantalla, quita el apostrofe inicial para habilitar linea
Donde = Trim(Donde)
Donde = Donde & IIf(Right(Donde, 1) = "\", "", "\")
Range(Celda).Select
If AutoFilterMode = False Then
Selection.AutoFilter
ElseIf FilterMode Then
ActiveSheet.ShowAllData
End If
'1.- Carga matriz de clientes a filtrar
Dim ListClie() As Variant
clie = 0
NroCliente = ""
Do While Not IsEmpty(ActiveCell)
If ActiveCell.Value <> NroCliente Then
NroCliente = ActiveCell.Value
ReDim Preserve ListClie(clie)
ListClie(clie) = NroCliente
clie = clie + 1
End If
ActiveCell.Offset(1).Select
Loop
'2.- Filtra cliente por cliente
Range(Celda).Select
For clie = 1 To UBound(ListClie)
Selection.AutoFilter Field:=1, Criteria1:=ListClie(clie)
NewFileName = Donde & ListClie(clie) & ".xls"
Selection.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
Range("A5").Select 'Celda donde se pegarán los datos en destino
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A5").Select
Application.DisplayAlerts = False ' si quieres evitar el mensaje de archivo existente, quita el apostrofe inicial para habilitar linea
ActiveWorkbook.SaveAs NewFileName
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
MsgBox "Proceso Terminado", vbInformation, "HECHO!!"
End Sub
Espero que te sirva.
Un abrazo!
Fernando
Pd: Disculpa la demora, pero actualmente estoy con mucho trabajo.
El procedimiento siguiente aplica un filtro sobre la base y en función de la lista de clientes (códigos) selecciona registros, abre libro nuevo, copia y los pega en él. Finalmente graba y cierra el archivo.
Ya sabes, abre el Editor de VBA y pega este código en un módulo nuevo:
Sub GenTodos()
' xgoro, indica dónde se guardarán los archivos
Donde = "C:\Mis documentos\"
' xgoro, indica celda donde está el primer código de cliente
Celda = "A4"
'------------- gracias!
'Application.ScreenUpdating = False ' si quieres evitar los movimientos de pantalla, quita el apostrofe inicial para habilitar linea
Donde = Trim(Donde)
Donde = Donde & IIf(Right(Donde, 1) = "\", "", "\")
Range(Celda).Select
If AutoFilterMode = False Then
Selection.AutoFilter
ElseIf FilterMode Then
ActiveSheet.ShowAllData
End If
'1.- Carga matriz de clientes a filtrar
Dim ListClie() As Variant
clie = 0
NroCliente = ""
Do While Not IsEmpty(ActiveCell)
If ActiveCell.Value <> NroCliente Then
NroCliente = ActiveCell.Value
ReDim Preserve ListClie(clie)
ListClie(clie) = NroCliente
clie = clie + 1
End If
ActiveCell.Offset(1).Select
Loop
'2.- Filtra cliente por cliente
Range(Celda).Select
For clie = 1 To UBound(ListClie)
Selection.AutoFilter Field:=1, Criteria1:=ListClie(clie)
NewFileName = Donde & ListClie(clie) & ".xls"
Selection.CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
Workbooks.Add
Range("A5").Select 'Celda donde se pegarán los datos en destino
Selection.PasteSpecial Paste:=xlValues
Selection.PasteSpecial Paste:=xlFormats
Application.CutCopyMode = False
Range("A5").Select
Application.DisplayAlerts = False ' si quieres evitar el mensaje de archivo existente, quita el apostrofe inicial para habilitar linea
ActiveWorkbook.SaveAs NewFileName
ActiveWorkbook.Close
Application.DisplayAlerts = True
Next
Application.ScreenUpdating = True
MsgBox "Proceso Terminado", vbInformation, "HECHO!!"
End Sub
Espero que te sirva.
Un abrazo!
Fernando
Pd: Disculpa la demora, pero actualmente estoy con mucho trabajo.
