Guardar macro separados por ";" y no por "|"
Para Dante Amor
Hola Dante me conseguí una macro y lo adapte a lo que necesito; pero al momento de guardar el archivo los datos de cada columna me los separa por"|", y yo quisiera que me ayudes para que me guarde separados por ";"
Option Private Module
Public Ruta As String
#If VBA7 And Win64 Then
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As LongPtr
pidlRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As LongPtr
lpfn As LongPtr
lParam As LongPtr
iImage As LongPtr
End Type
'Si es de 64 bits
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As LongPtr, ByVal pszPath As String) As LongPtr
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr
#Else
'Si es de 32 bits
Private Type BROWSEINFO ' used by the function GetFolderName
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
#End If
Function GetFolderName(Msg As String) As String
' returns the name of the folder selected by the user
#If VBA7 And Win64 Then
'Si es de 64 bits
Dim bInfo As BROWSEINFO, path As String, r As LongPtr
Dim X As LongPtr, pos As Integer
#Else
'Si es de 32 bits
Dim bInfo As BROWSEINFO, path As String, r As Long
Dim X As Long, pos As Integer
#End If
bInfo.pidlRoot = 0& ' Root folder = Desktop
If IsMissing(Msg) Then
bInfo.lpszTitle = "Seleccione una Carpeta"
' the dialog title
Else
bInfo.lpszTitle = "¿En que carpeta desea guardar el Archivo a generar?" ' the dialog title
End If
bInfo.ulFlags = &H1 ' Type of directory to return
X = SHBrowseForFolder(bInfo) ' display the dialog
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal X, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetFolderName = Left(path, pos - 1) & "\"
If Right(GetFolderName, 2) = "\\" Then GetFolderName = Left(GetFolderName, Len(GetFolderName) - 1)
Else
GetFolderName = ""
End If
End Function
Sub TestGetFolderName()
Dim FolderName As String
FolderName = GetFolderName("Select a folder")
If FolderName = "" Then
MsgBox "No has seleccionado una carpeta válida" & Chr(13) & "Por defecto se seleccionará el disco C:/", vbCritical, "SELECCIONE UNA CARPETA"
Ruta = "C:\"
Else
Ruta = FolderName
End If
End Sub
Sub Procesar()
Call TestGetFolderName
Call Colocar_Formula
Call Arrastre
Call Guardar_txt
End Sub
Sub Colocar_Formula()
Hoja2.Columns("a:a").Clear
Select Case ActiveSheet.Name
Case Is = "Costos - Gastos"
Hoja2.Range("A1").FormulaLocal = "='" & Hoja2.Range("n1").Value
Case Is = "Ingresos"
Hoja2.Range("A1").FormulaLocal = "=" & Hoja2.Range("o1").Value
Case Is = "Seguros"
Hoja2.Range("A1").FormulaLocal = "=" & Hoja2.Range("p1").Value
Case Else
Hoja2.Range("A1").FormulaLocal = "=" & Hoja2.Range("q1").Value
End Select
Application.Volatile
End Sub
Sub Arrastre()
UltimaCosto = Hoja1.Range("b65536").End(xlUp).Row - 7
If UltimaCosto > 1 Then
Hoja2.Range("A1").AutoFill Destination:=Hoja2.Range("A1:a" & UltimaCosto), Type:=xlFillDefault
End If
End Sub
Sub Guardar_txt()
On Error Resume Next
Z = Hoja2.Range("A65536").End(xlUp).Row
Dim r As Range, c As Range
Dim sTemp As String
Open Ruta & Range("b5").Value For Output As #1
For Each r In Hoja2.Range("A1:A" & Z).Rows
sTemp = ""
For Each c In r.Cells
sTemp = sTemp & c.Text & Chr(9)
Next c
'Get rid of trailing tabs
While Right(sTemp, 1) = Chr(9)
sTemp = Left(sTemp, Len(sTemp) - 1)
Wend
Print #1, sTemp
Next r
Close #1
MsgBox "El archivo de nombre: " & Range("b5").Value & " fue creado con éxito" & Chr(13) & "Ubicalo en: " & Ruta, vbInformation, "PDT 3500 OPERACIONES CON TERCEROS (DAOT)"
End Sub