Right now I'm trying to save an excel sheet with VBA as a pipe delimited unicode file with a .txt extension.
I've figured out how to save it as unicode with code as follows
ActiveWorkbook.SaveAs FileName:=FileName, _
FileFormat:=xlUnicodeText
But this will save it as tab delimited. I can't seem to find an option with MSDN, as their page on FileFormat isn't very helpful.
As saving as a .csv doesn't keep it unicode, you can try replacing the tabs by pipes in the text file, using a macro like this one, found here. You can call it using
call TextFileReplace("C:\temp\test.txt","C:\temp\test2.txt",vbtab,"|")
Public Sub TextFileReplace(ByVal sFile As String, ByVal sNewFile As String, ByVal sFind As String, ByVal sReplace As String)
Dim iFile As Integer
Dim sTextBuffer As String
'
' Get the next available file handle
iFile = FreeFile
' Open the source file (sFile) for read access
Open sFile For Binary Access Read As iFile
' Create a buffer that will hold the contents of the file
sTextBuffer = Space(LOF(iFile))
' Read the contents of the file into the buffer
Get #iFile, , sTextBuffer
' Close the file
Close iFile
' Use the "Replace" function to replace all instances of
' (sFind) in the buffer with the value in (sReplace)
sTextBuffer = Replace(sTextBuffer, sFind, sReplace)
' Get the next available file handle
iFile = FreeFile
' Open/Create the new file for write access
Open sNewFile For Binary Access Write As iFile
' Write the modified buffer contents to the file
Put #iFile, , sTextBuffer
' Close the file
Close iFile
End Sub
I should also point out that search-n-replace will not properly fix quoted delimiters.
Related
Every time I use this code, for some reason, double quotation marks appear for cell's output from beginning to ending. Anyway how I can remove these quotation marks?
I tried using a basic VBA, where it copies data from a certain column and converts it to a txt file.
Dim s As String, FileName As String, FileNum As Integer
' Define full pathname of TXT file
FileName = ThisWorkbook.Path & "\2019.con"
' Copy range to the clipboard
Range("A2", Cells(Rows.Count, "A").End(xlUp)).Copy
' Copy column content to the 's' variable via clipboard
With New DataObject
.GetFromClipboard
s = .GetText
End With
Application.CutCopyMode = False
' Write s to TXT file
FileNum = FreeFile
If Len(Dir(FileName)) > 0 Then Kill FileName
Open FileName For Binary Access Write As FileNum
Put FileNum, , s
Close FileNum
Actual Result:
"CONT=10"
"."
"."
"."
Desired Result:
CONT=10
.
.
.
You should use Print not Write if you don't want the quote marks
I am a technical writer and not much of a coder, I have thousands of .xml files that combined create a book. I used a VBA script from this website to rename all of the files to fit within the new guidelines, now I need to go into the xml code and find all references to those links and replace them with the new file name.
I have an excel spreadsheet where in column A it has the old file name and in column B it has the new file name.
The tag looks like this:
<?iads.link docref="R381"?>
It needs to find "R381" in column A and replace it with "R01081-1-1520-237", the file name in the adjacent cell in column B.
The Tag needs to look like this:
<?iads.link docref="R01081-1-1520-237"?>
I tried using the code from the question How can I Find/Replace multiple strings in an xml file? but it did not work and I'm not even sure if that's the correct question to be asking
My current code looks lie this:
Option Explicit ' Use this !
Public Sub ReplaceXML(rFindReplaceRange As Range) ' Pass in the find-replace range
Dim sBuf As String
Dim sTemp As String
Dim iFileNum As Integer
Dim sFileName As String
Dim i As Long
' Edit as needed
sFileName = "C:\Users\s37739\Desktop\chap3"
iFileNum = FreeFile
Open sFileName For Input As iFileNum
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
' Loop over the replacements
For i = 1 To rFindReplaceRange.Rows.Count
If rFindReplaceRange.Cells(i, 1) <> "" Then
sTemp = Replace(sTemp, rFindReplaceRange.Cells(i, 1), rFindReplaceRange(i, 2))
End If
Next i
' Save file
iFileNum = FreeFile
' Alter sFileName first to save to a different file e.g.
sFileName = "C:\Users\s37739\Desktop\chap3"
Open sFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End Sub
Sub mike1()
End Sub
You are passing the file path when in fact you should be passing the fully qualified file name (file path and file name).
You need to edit those lines
' Edit as needed
sFileName = "C:\Users\s37739\Desktop\chap3"
'...
' Alter sFileName first to save to a different file e.g.
sFileName = "C:\Users\s37739\Desktop\chap3"
With
' Edit as needed
sFileName = "C:\Users\s37739\Desktop\chap3\yourfilename.xml"
'...
' Alter sFileName first to save to a different file e.g.
sFileName = "C:\Users\s37739\Desktop\chap3\yourNEWfilename.xml"
Also, remember to provide the correct Range when running the procedure.
Supposing your Range goes from "A1:B50" you can edit your mike1 sub as follows:
Sub mike1()
' Change range as desired
Call ReplaceXML(ThisWorkbook.Worksheets("YourSheetName").Range("A1:B50"))
End Sub
After that, all you need to do is run mike1 from the Immediate window.
Access using Alt+F11 for the VBA editor then View -> Immediate.
You should see a new window at the bottom of the screen. Just type mike1 in there and hit Enter
UPDATE:
Ideally, you should first try to understand the code you currently have and change it make it work on multiple files instead of a single one per run. There are many places around that can give you examples on how to do that, either recursively or in a loop directly into a function. There are many ways to do it and also many material around it.
That being said, you can find below one of the many approaches to solve your issue. The following code consists of two Subs that you can copy/paste into your module.
You need to change the value of HOST_PATH with the main folder and the findReplaceRange with the range to work with. You need to change "Sheet1" with the name of your worksheet and the "A1:B10" with your actual range. After that, just run the ReplaceXML2() Sub.
Note: this will update ALL XML files under the folder provided, so make sure you gave it enough testing (preferably, backup your files) before running it for the entire folder. If you have further issues I suggest asking another question.
Code:
Public Sub ReplaceXML2()
Const HOST_PATH = "C:\Users\s37739\Desktop\chap3\" ' change accordingly
Dim findReplaceRange As Range
Set findReplaceRange = ThisWorkbook.Worksheets("Sheet1").Range("A1:B10") ' change accordingly
Dim FileSystem As Object
Set FileSystem = CreateObject("Scripting.FileSystemObject")
Call RecursivelyReplaceXML(FileSystem.GetFolder(HOST_PATH), findReplaceRange)
End Sub
Public Sub RecursivelyReplaceXML(parentFolder, rFindReplaceRange As Range) ' Pass in the folder and the find-replace range
Dim subFolder As Object
For Each subFolder In parentFolder.SubFolders
RecursivelyReplaceXML subFolder, rFindReplaceRange
Next
Dim file As Object
For Each file In parentFolder.Files
If Right(file.Name, 4) = ".xml" Then
Dim iFileNum As Integer
Dim sTemp As String
Dim sBuf As String
Dim i As Long
Dim fullFileName As String
fullFileName = file.Path
iFileNum = FreeFile
Open fullFileName For Input As iFileNum
sTemp = "" ' clean up to read the next file
Do Until EOF(iFileNum)
Line Input #iFileNum, sBuf
sTemp = sTemp & sBuf & vbCrLf
Loop
Close iFileNum
' Loop over the replacements
For i = 1 To rFindReplaceRange.Rows.count
If rFindReplaceRange.Cells(i, 1) <> "" Then
sTemp = Replace(sTemp, rFindReplaceRange.Cells(i, 1), rFindReplaceRange(i, 2))
End If
Next i
' Save file
iFileNum = FreeFile
' WARNING: New name definition commented out,
' which means all files will be replaced with newer versions!!
'===
' Alter fullFileName first to save to a different file e.g.
' fullFileName = "C:\Users\s37739\Desktop\chap3\"
Open fullFileName For Output As iFileNum
Print #iFileNum, sTemp
Close iFileNum
End If
Next
End Sub
I would like to know if it is possible with Excel to save a file with a delimiter that I can choose?
Thank you
Yes, this is possible.
Go to your Region and Language settings in the Control Panel of Windows.
Click "Additional Settings" on tab "Format".
Change the List Separator to your own custom delimiter character.
May be this could give some help:
Sub changeCharacter()
Dim myFile As String
Dim text As String
Dim textline As String
myFile = Application.GetOpenFilename() 'open your TXT/CSV file
Open myFile For Input As #1 'open just for input
Do Until EOF(1)
Line Input #1, textline
textline = Replace(textline, ",", "#")
text = text & Chr(10) & textline
Loop
'#####################################3
'EOF = End Of File
' and this function sends true when reach the last
' line of the file...
'
'Line Input #1, textline
' take the next line in the TXT/CSV file an store it inside
' "textline" to replace the character "," for "#" using:
'textline = Replace(textline, ",", "#")
' and store the result again inside "textline"
' and finally, store the result into "text" to use it later
'#####################################3
Close #1 'close the TXT/CSV fiel
Open myFile For Output As #1 'open the same file againg,
'now to store the resulting data
'inside the file
Write #1, text 'write the data into the file
Close #1 'close it againg, now with the changes...
End Sub
This is not to save the file with a different delimeter, but could help to change it.
I need to export data from Excel to a comma delimited file. I am using a button that runs a macro that creates the text file in a location I specify and exports values.
But, I want to copy this Excel with the same macro, and add different values. When I run the macro in the copied Excel file I want the same text delimited file to add these values under the previous set of values, not overwrite the values from the first Excel file.
How is this possible? I want to use the same text file each time.
Append using following routine:
Sub writeCSV(ByVal thisRange As Range, ByVal filePath As String, _
Optional ByVal fileAppend As Boolean = False)
Dim cLoop As Long, rLoop As Long
Dim ff As Long, strRow As String
ff = FreeFile
If fileAppend Then
Open filePath For Append As #ff
Else
Open filePath For Output As #ff
End If
For rLoop = 1 To thisRange.Rows.Count
strRow = ""
For cLoop = 1 To thisRange.Columns.Count
If cLoop > 1 Then strRow = strRow & ","
strRow = strRow & thisRange.Cells(rLoop, cLoop).Value
Next 'cLoop
Print #ff, strRow
Next 'rLoop
Close #ff
End Sub
Example usage
writeCSV sheet1, "c:\test.txt", true
It is easy to do it by using a StreamWriter. The AppendText function of the FileInfo class returns one that is configured for appending text to an existing file.
I write my example as pseudo code, as I don't know how you are retrieving the information from Excel. The File handling part, however, is complete:
Dim file As New FileInfo("C:\myOuputFile.csv")
Using writer = file.AppendText()
While isRowAvailable
writer.WriteLine("Write next row")
End While
End Using
The Using statement automatically closes the file at the end.
I'm trying to write a file using VBA. My code is below. It worked the first time, but when i closed the excel file (.xlsm) and try to use it again, it doesn't work.
I do not get any errors when running the macro but the new file does not appear
Sub LogInformation(LogMessage As String)
Const LogFileName As String = "TEXTFILE.db"
Dim FileNum As Integer
FileNum = FreeFile ' next file number
Open LogFileName For Append As #FileNum ' creates the file if it doesn't exist
Print #FileNum, LogMessage ' write information at the end of the text file
Close #FileNum ' close the file
End Sub
Sorry guys. That was dumb.
The default relative path is in User/%MyUser%/Documents.
I need to use ChDir then open/write/close the file.
Chdir(ActiveWorkbook.Path)