Generar varios archivos txt a partir de un excel
Hola, 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.txt y así sucesivamente con el resto de clientes. Un cliente puede tener 1 o más transacciones. Ojalá me puedas ayudar.
Esta pregunta ya la habías contestado pero para generar varios archivos de excel. Mi necesidad es la misma pero para generar archivos txt.
¿Me ayudas por favor?
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.txt y así sucesivamente con el resto de clientes. Un cliente puede tener 1 o más transacciones. Ojalá me puedas ayudar.
Esta pregunta ya la habías contestado pero para generar varios archivos de excel. Mi necesidad es la misma pero para generar archivos txt.
¿Me ayudas por favor?
Respuesta de jferg
1
Adapta el siguiente código a tus necesidades.
Para que funcione necesariamente tienes que insertar un Userform. No importa que no lo muestres o le pongas controles. Solo tienes que crearlo:
Dim FF As Integer
Dim Fila As Integer
Dim Clip As New MSForms.DataObject
Dim Datos As String
FF = FreeFile
Open "C:\Ruta\" & "NombreArchivo.txt" For Output As #FF
Fila = 1 'dependiendo de donde inicien tus datos
ThisWorkbook.Worksheets("MiHoja").Activate
ThisWorkbook.Worksheets("MiHoja").Select
Do While Not IsEmpty(ThisWorkbook.Worksheets("MiHoja").Cells(Fila, "A"))
ThisWorkbook.Worksheets("MiHoja").Range(Cells(Fila, "A"), Cells(Fila, "D")).Copy
Clip.GetFromClipboard
Datos = Clip.GetText
Print #FF, Mid(Datos, 1, Len(Datos) - 1)
Fila = Fila + 1
Loop
Close FF
MsgBox "Archivo generado exitosamente", vbInformation, "OK"
Para que funcione necesariamente tienes que insertar un Userform. No importa que no lo muestres o le pongas controles. Solo tienes que crearlo:
Dim FF As Integer
Dim Fila As Integer
Dim Clip As New MSForms.DataObject
Dim Datos As String
FF = FreeFile
Open "C:\Ruta\" & "NombreArchivo.txt" For Output As #FF
Fila = 1 'dependiendo de donde inicien tus datos
ThisWorkbook.Worksheets("MiHoja").Activate
ThisWorkbook.Worksheets("MiHoja").Select
Do While Not IsEmpty(ThisWorkbook.Worksheets("MiHoja").Cells(Fila, "A"))
ThisWorkbook.Worksheets("MiHoja").Range(Cells(Fila, "A"), Cells(Fila, "D")).Copy
Clip.GetFromClipboard
Datos = Clip.GetText
Print #FF, Mid(Datos, 1, Len(Datos) - 1)
Fila = Fila + 1
Loop
Close FF
MsgBox "Archivo generado exitosamente", vbInformation, "OK"
El UseForm que sugieres no resuelve el problema ya que sólo genera un archivo .txt y de acuerdo al código anexo (creación de otro experto) a partir de una hoja de excel se van generando varios archivos xls. La necesidad mía es que en lugar de que sean xls sean txt.
Sub GenTodos()
' xgoro, indica dónde se guardarán los archivos
Donde = "C:\temp\"
' xgoro, indica celda donde está el primer código de cliente
Celda = "A1"
'------------- 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
Ya intenté adaptar lo siguiente después de .copy y hasta antes de la sentencia Next.
Run Shell("C:\WINDOWS\SYSTEM32\NOTEPAD.EXE", 1)
SendKeys "%", True
SendKeys "EP", True
Next
Y sí crea los archivos TXT pero no toma el nombre de cada uno de los archivos que sí se generan con el primer código.
Espero haberme hecho entender.
Sub GenTodos()
' xgoro, indica dónde se guardarán los archivos
Donde = "C:\temp\"
' xgoro, indica celda donde está el primer código de cliente
Celda = "A1"
'------------- 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
Ya intenté adaptar lo siguiente después de .copy y hasta antes de la sentencia Next.
Run Shell("C:\WINDOWS\SYSTEM32\NOTEPAD.EXE", 1)
SendKeys "%", True
SendKeys "EP", True
Next
Y sí crea los archivos TXT pero no toma el nombre de cada uno de los archivos que sí se generan con el primer código.
Espero haberme hecho entender.
Lo siento pero en realidad no te entiendo. En tu pregunta original hablas de un archivo txt.
Por favor trata de explicarme de manera breve pero claro que es exactamente lo que encsitas para poder ayudaret.
Por favor trata de explicarme de manera breve pero claro que es exactamente lo que encsitas para poder ayudaret.
Aunque no me entendiste, me sirvió de mucho lo que me enviaste y ya adaptado a mi necesidad quedó así:
Sub GeneraArchivos()
Dim Clip As New MSForms.DataObject
Dim FF As Integer
Dim Datos As String
Donde = "C:\temp\" 'indica dónde se guardarán los archivos
Celda = "A4" 'indica celda donde está el primer registro patronal
'Application.ScreenUpdating = False ' si quieres evitar los movimientos de pantalla, quitar 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 a filtrar
Dim ListaRegistros() As Variant
reg = 0
NroRegistro = ""
Do While Not IsEmpty(ActiveCell)
If ActiveCell.Value <> NroRegistro Then
NroRegistro = ActiveCell.Value
ReDim Preserve ListaRegistros(reg)
ListaRegistros(reg) = NroRegistro
reg = reg + 1
End If
ActiveCell.Offset(1).Select
Loop
'2.- Filtra por registro patronal
Range(Celda).Select
For reg = 1 To UBound(ListaRegistros)
Selection.AutoFilter Field:=1, Criteria1:=ListaRegistros(reg)
NewFileName = Donde & ListaRegistros(reg) & ".txt"
FF = FreeFile
Open NewFileName For Output As #FF
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 1).Resize(tbl.Rows.Count - 1, tbl.Columns.Count - 1).Copy
Clip.GetFromClipboard
Datos = Clip.GetText
Print #FF, Mid(Datos, 1, Len(Datos) - 1)
Close FF
Next
Application.ScreenUpdating = True
MsgBox "Proceso Terminado", vbInformation, "HECHO!!"
End Sub
Muchas gracias.
Sub GeneraArchivos()
Dim Clip As New MSForms.DataObject
Dim FF As Integer
Dim Datos As String
Donde = "C:\temp\" 'indica dónde se guardarán los archivos
Celda = "A4" 'indica celda donde está el primer registro patronal
'Application.ScreenUpdating = False ' si quieres evitar los movimientos de pantalla, quitar 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 a filtrar
Dim ListaRegistros() As Variant
reg = 0
NroRegistro = ""
Do While Not IsEmpty(ActiveCell)
If ActiveCell.Value <> NroRegistro Then
NroRegistro = ActiveCell.Value
ReDim Preserve ListaRegistros(reg)
ListaRegistros(reg) = NroRegistro
reg = reg + 1
End If
ActiveCell.Offset(1).Select
Loop
'2.- Filtra por registro patronal
Range(Celda).Select
For reg = 1 To UBound(ListaRegistros)
Selection.AutoFilter Field:=1, Criteria1:=ListaRegistros(reg)
NewFileName = Donde & ListaRegistros(reg) & ".txt"
FF = FreeFile
Open NewFileName For Output As #FF
Set tbl = ActiveCell.CurrentRegion
tbl.Offset(1, 1).Resize(tbl.Rows.Count - 1, tbl.Columns.Count - 1).Copy
Clip.GetFromClipboard
Datos = Clip.GetText
Print #FF, Mid(Datos, 1, Len(Datos) - 1)
Close FF
Next
Application.ScreenUpdating = True
MsgBox "Proceso Terminado", vbInformation, "HECHO!!"
End Sub
Muchas gracias.
