Exportar de Excel a un archivo de texto
Necesito exportar un rango de datos de Excel de longitud variable a un archivo de txt en una ruta fija
'el rango lo selecciono
Range("E1").Select
Range(Selection, Selection.End(xlDown)).Select
en las celdas de la hoja hay otros datos que no necesito exportar
el archivo de texto seria como un backup en texto plano de ese rango de celdas.
'el rango lo selecciono
Range("E1").Select
Range(Selection, Selection.End(xlDown)).Select
en las celdas de la hoja hay otros datos que no necesito exportar
el archivo de texto seria como un backup en texto plano de ese rango de celdas.
1 respuesta
Respuesta de caranbis
1
'A tu servicio.
Sub GuardarSeleccion()
Dim nombre As String
Dim carpeta As String
Dim fila As Double
Dim Renglon As String
Inicio:
carpeta = "C:\Temp\"
nombre = InputBox("Nombre del Archivo")
If Not nombre <> "" Then Exit Sub
Set Neo = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Archivo = Neo.CreateTextFile(carpeta & nombre & ".txt", False) ' Leer:
'False hará que si el archivo existe, éste no sea sobreescrito.
If Err = 58 Then GoTo ExisteArchivo
fila = 0
For Each celda In Selection
Application.StatusBar = celda & " :::: " & Renglon
If celda.Row <> fila Then
If fila > 0 Then Archivo.WriteLine Renglon
fila = celda.Row
Renglon = celda
Else
If Renglon <> "" Then
Renglon = Renglon & Chr(9) & celda
Else
Renglon = celda
End If
End If
Next
Archivo.WriteLine Renglon
Archivo.Close
Exit Sub
ExisteArchivo:
Err.Clear
MsgBox "El ya archivo existe"
GoTo Inicio
End Sub
Sub GuardarSeleccion()
Dim nombre As String
Dim carpeta As String
Dim fila As Double
Dim Renglon As String
Inicio:
carpeta = "C:\Temp\"
nombre = InputBox("Nombre del Archivo")
If Not nombre <> "" Then Exit Sub
Set Neo = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Archivo = Neo.CreateTextFile(carpeta & nombre & ".txt", False) ' Leer:
'False hará que si el archivo existe, éste no sea sobreescrito.
If Err = 58 Then GoTo ExisteArchivo
fila = 0
For Each celda In Selection
Application.StatusBar = celda & " :::: " & Renglon
If celda.Row <> fila Then
If fila > 0 Then Archivo.WriteLine Renglon
fila = celda.Row
Renglon = celda
Else
If Renglon <> "" Then
Renglon = Renglon & Chr(9) & celda
Else
Renglon = celda
End If
End If
Next
Archivo.WriteLine Renglon
Archivo.Close
Exit Sub
ExisteArchivo:
Err.Clear
MsgBox "El ya archivo existe"
GoTo Inicio
End Sub
La línea:
Application.StatusBar = celda & " :::: " & Renglon
Se puede anular, era sólo de consulta rápida.
Application.StatusBar = celda & " :::: " & Renglon
Se puede anular, era sólo de consulta rápida.
'Mejor dicho deja esta macro:
Sub GuardarSeleccion()
Dim nombre As String
Dim carpeta As String
Dim fila As Double
Dim Renglon As String
Inicio:
carpeta = "C:\Temp\"
nombre = InputBox("Nombre del Archivo")
If Not nombre <> "" Then Exit Sub
Set Neo = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Archivo = Neo.CreateTextFile(carpeta & nombre & ".txt", False) ' Leer:
'False hará que si el archivo existe, éste no sea sobreescrito.
If Err = 58 Then GoTo ExisteArchivo
fila = 0
For Each celda In Selection
If celda.Row <> fila Then
If fila > 0 Then Archivo.WriteLine Renglon
fila = celda.Row
Renglon = celda
Else
If Renglon <> "" Then
Renglon = Renglon & Chr(9) & celda
End If
End If
Next
Archivo.WriteLine Renglon
Archivo.Close
Exit Sub
ExisteArchivo:
Err.Clear
MsgBox "El ya archivo existe"
GoTo Inicio
End Sub
Sub GuardarSeleccion()
Dim nombre As String
Dim carpeta As String
Dim fila As Double
Dim Renglon As String
Inicio:
carpeta = "C:\Temp\"
nombre = InputBox("Nombre del Archivo")
If Not nombre <> "" Then Exit Sub
Set Neo = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set Archivo = Neo.CreateTextFile(carpeta & nombre & ".txt", False) ' Leer:
'False hará que si el archivo existe, éste no sea sobreescrito.
If Err = 58 Then GoTo ExisteArchivo
fila = 0
For Each celda In Selection
If celda.Row <> fila Then
If fila > 0 Then Archivo.WriteLine Renglon
fila = celda.Row
Renglon = celda
Else
If Renglon <> "" Then
Renglon = Renglon & Chr(9) & celda
End If
End If
Next
Archivo.WriteLine Renglon
Archivo.Close
Exit Sub
ExisteArchivo:
Err.Clear
MsgBox "El ya archivo existe"
GoTo Inicio
End Sub
Caranbis, muchas gracias por tu respuesta, la probé también y resulta excelente.
Al final modifique otro código vba y me quedé con esta versión que me costó un día entero pulir.
Dejo el código para todos aquellos que quieran crear macros de IBM Basis desde Excel (o sea con extensión .mac, lo mismo vale para .txt) con los datos de un rango.
Caranbis, nuevamente gracias, tu código es correcto.
El mío:
Sub Exporta()
' Exportador de Rango de Celdas a archivo de Macros Basis (By Jorge Lacuadra)
Dim FileSysObj As Object
Dim ArchivoMac As Object
Dim Celda
ActiveSheet.Range("E1", ActiveSheet.Range("E1").End(xlDown)).Select
Set FileSysObj = CreateObject("Scripting.FileSystemobject")
Set ArchivoMac = FileSysObj.CreateTextFile("C:\Archivos de programa\IBM\Client Access\Emulator\Private\Test.mac", True)
For Each Celda In Selection
ArchivoMac.WriteLine Celda
Next
ArchivoMac.Close
MsgBox "Archivo 'Test.mac' salvado en C:\Archivos de programa\IBM\Client Access\Emulator\Private\ ", vbInformation
End Sub
Al final modifique otro código vba y me quedé con esta versión que me costó un día entero pulir.
Dejo el código para todos aquellos que quieran crear macros de IBM Basis desde Excel (o sea con extensión .mac, lo mismo vale para .txt) con los datos de un rango.
Caranbis, nuevamente gracias, tu código es correcto.
El mío:
Sub Exporta()
' Exportador de Rango de Celdas a archivo de Macros Basis (By Jorge Lacuadra)
Dim FileSysObj As Object
Dim ArchivoMac As Object
Dim Celda
ActiveSheet.Range("E1", ActiveSheet.Range("E1").End(xlDown)).Select
Set FileSysObj = CreateObject("Scripting.FileSystemobject")
Set ArchivoMac = FileSysObj.CreateTextFile("C:\Archivos de programa\IBM\Client Access\Emulator\Private\Test.mac", True)
For Each Celda In Selection
ArchivoMac.WriteLine Celda
Next
ArchivoMac.Close
MsgBox "Archivo 'Test.mac' salvado en C:\Archivos de programa\IBM\Client Access\Emulator\Private\ ", vbInformation
End Sub
