I need help creating separate text files from each row in an excel spread sheet called "worksheet". I want the text files to be named with content of Column A + “Result”+ Column H (Which should be hidden in the .txt file, with columns B-G being the content, I have done the coding. Please find the followings. But I have received whitespace in the .txt output file. Please find the screenshots. I am unable to TRIM this white space.
How would I proceed further to solve the problem?
Thanks in Advance.
VBA Code:
Sub WriteTotxt()
Const forReading = 1, forAppending = 3, fsoForWriting = 2
Dim fs, objTextStream, sText As String
Dim lLastRow As Long, lRowLoop As Long, lLastCol As Long, lColLoop As Long
lLastRow = Cells(Rows.Count, 1).End(xlUp).Row
For lRowLoop = 1 To lLastRow
Set fs = CreateObject("Scripting.FileSystemObject")
Set objTextStream = fs.opentextfile("D:\EXCEL_TXT_TEST\New folder\" & Cells(lRowLoop, 8) & "-" & "RESULT" & "-" & Cells(lRowLoop, 1) & ".txt", fsoForWriting, True)
sText = ""
sText1 = ""
For lColLoop = 1 To 7
If lColLoop <> 7 Then
sText = sText & "<" & Cells(lColLoop) & ">" & "," & Chr(0)
sText1 = sText1 & Cells(lRowLoop, lColLoop) & "," & Chr(0)
Else
sText = sText & "<" & Cells(lColLoop) & ">" & Chr(0)
sText1 = sText1 & Cells(lRowLoop, lColLoop) & Chr(0)
End If
Next lColLoop
objTextStream.writeline (Left(sText, Len(Trim(sText)) - 1))
objTextStream.writeline (Left(sText1, Len(Trim(sText1)) - 1))
objTextStream.Close
Set objTextStream = Nothing
Set fs = Nothing
Next lRowLoop
End Sub
You can remove all the blank lines from a string like this
mystr = replace(mystr, vblf & vbcr, "")
This will remove empty lines, not lines that contain spaces or other characters you can't see though..
I can help with your code as well, but have you tried a simple approach first?
Why don't you just file --> save as .csv, and replace your header? Your data output will be VERY similar, save for the " " space preceding your listed entries. Lazy but easy.
adapt this to your module, and you can erase like everything you have ...
ActiveWorkbook.SaveAs Filename:= _
"c:\MyFile.csv", FileFormat:=xlCSV _
, CreateBackup:=False
Then, just read your data back in, and string operations will be easy.
Related
I am trying to replace part of the code in my Python script using VBA.
I need to replace two lines of code with nothing. The VBA is not able to "find" these two lines in the code, which I think is because of the spaces, tabs in the Python script.
strContents = Replace(strContents, "if time == 12:" & vbNewLine & vbTab & "Freq = 1", "")
' *** THIS IS THE MOST CRUCIAL LINE - WHICH IS FAILING RIGHT NOW***
I am not adding the rest of the code of finding and replacing as it works, and the issue is finding this particular expression.
The Python script I am trying to delete (or replace with nothing):
if time == 12:
Freq = 1
else:
Freq = 12
In another attempt, I tried counting the number of spaces, and asking the VBA to find the text in the Python script with the number of spaces I could count in the script.
Thanks #Aldert for responding, here is the entire code :
Sub FindReplaceTrials()
Dim objFSO
Const ForReading = 1
Const ForWriting = 2
Dim objTS 'define a TextStream object
Dim strContents As String
Dim path As String
Dim fileSpec As String
Dim filename As String
path = Application.ActiveWorkbook.path
For m = 4 To 11 ' we need to make this dynamic too
filename = Worksheets("ScriptName").Cells(m, 1).Value
fileSpec = path & "\" & filename & ".py"
'MsgBox (vbCrLf & vbTab & "else:")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTS = objFSO.OpenTextFile(fileSpec, ForReading)
If Worksheets(4).Range("B" & 7).Value = 1 Then
If filename = "econ" Then
strContents = objTS.ReadAll
strContents = Replace(strContents, "if time == 12:" & vbCrLf & Space(20) & "freq = 1" & vbCrLf & Space(16) & "else:" & vbCrLf & Space(20) & "freq = 12", "freq = 12")
Set objTS = objFSO.OpenTextFile(fileSpec, ForWriting)
objTS.Write strContents
objTS.Close
End If
End If
objTS.Close
Next
End Sub
The vbCrLf & Space() objects worked to find the right sentences in the script.
Is it possible to turn an SRT file, which is used for subtitles in videos into a dataset?
When imported into Excel, the SRT file format looks like this:
1
00:00:03,000 --> 00:00:04,000
OVERLAPS PURE COINCIDENCE THAT
...
This pattern continues as time in the "video"/transcript goes on. I'd like to format the SRT file this way:
number ; start ; end ; text
1 ; 00:00:03,000 ; 00:00:04,000 ; OVERLAPS PURE COINCIDENCE THAT
The VBA procedure below loads a standard .srt (SubRip Movie Subtitle File) from a local file and splits it into rows/columns on the active Excel worksheet.
Import SRT subtitles from Local File:
Sub importSRTfromFile(fName As String)
'Loads SRT from local file and converts to columns in Active Worksheet
Dim sIn As String, sOut As String, sArr() As String, x As Long
'load file
Open fName For Input As #1
While Not EOF(1)
Line Input #1, sIn
sOut = sOut & sIn & vbLf
Wend
Close #1
'convert LFs to delimiters & split into array
sOut = Replace(sOut, vbLf & vbLf, vbCr)
sOut = Replace(Replace(sOut, vbLf, "|"), " --> ", "|")
sArr = Split(sOut, vbCr)
'check if activesheet is blank
If ActiveSheet.UsedRange.Cells.Count > 1 Then
If MsgBox(UBound(sArr) & " rows found." & vbLf & vbLf & _
"Okay to clear worksheet '" & ActiveSheet.Name & "'?", _
vbOKCancel, "Delete Existing Data?") <> vbOK Then Exit Sub
ActiveSheet.Cells.ClearContents
End If
'breakout into rows
For x = 1 To UBound(sArr)
Range("A" & x) = sArr(x)
Next x
'split into columns
Columns("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|"
MsgBox "Imported " & UBound(sArr) & " rows from:" & vbLf & fName
End Sub
Example Usage:
Sub test_FileImport()
importSRTfromFile "c:\yourPath\yourFilename.srt"
End Sub
Import SRT subtitles from Website URL:
Alternatively, you can import an .srt (or other similar text files) from a Website URL such as https://subtitle-index.org/ with this:
Sub importSRTfromWeb(url As String)
'Loads SRT from URL and converts to columns in Active Worksheet
Dim sIn As String, sOut As String, sArr() As String, rw As Long
Dim httpData() As Byte, XMLHTTP As Object
'load file from URL
Set XMLHTTP = CreateObject("MSXML2.XMLHTTP")
XMLHTTP.Open "GET", url, False
XMLHTTP.send
httpData = XMLHTTP.responseBody
Set XMLHTTP = Nothing
sOut = StrConv(httpData, vbUnicode)
'convert LFs to delimiters & split into array
sOut = Replace(sOut, vbLf & vbLf, vbCr)
sOut = Replace(Replace(sOut, vbLf, "|"), " --> ", "|")
sArr = Split(sOut, vbCr)
'check if activesheet is blank
If ActiveSheet.UsedRange.Cells.Count > 1 Then
If MsgBox(UBound(sArr) & " rows found." & vbLf & vbLf & _
"Okay to clear worksheet '" & ActiveSheet.Name & "'?", _
vbOKCancel, "Delete Existing Data?") <> vbOK Then Exit Sub
ActiveSheet.Cells.ClearContents
End If
'breakout into rows
For rw = 1 To UBound(sArr)
Range("A" & rw) = sArr(rw)
Next rw
'split into columns
Columns("A:A").TextToColumns Destination:=Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|"
MsgBox "Imported " & UBound(sArr) & " rows from:" & vbLf & url
End Sub
Example Usage:
Sub testImport()
importSRTfromWeb _
"https://subtitle-index.org/download/4670541854528212663953859964/SRT/Pulp+Fiction"
End Sub
Many sites host free .srt's; you may have to right-click the download button to copy the link (which may have an .srt extension or might be a pointer, like the example above). The procedure won't work on .zip'd files.
More Information:
Wikipedia : SubRip & SRT
MSDN : Split Function (VBA)
Wikipedia : Newline characters
MSDN : UBound Function
MSDN : Range.TextToColumns Method (Excel)
SubRip Official Website
in the above code :
'breakout into rows
For rw = 1 To UBound(sArr)
Range("A" & rw) = sArr(rw)
Next rw
should be replaced with:
'breakout into rows
For rw = 0 To UBound(sArr)
Range("A" & rw+1) = sArr(rw)
Next rw
else the output will start from line 2
I used Vim and wrote a quick regex to convert a .srt into a .csv file for a translator friend who needed a similar conversion. The csv file can then be opened in Excel / LibreOffice and saved as .xls, .ods or whatever.
My friend didn't need the subtitle numbers to appear in the first column so the regex code looks like this :
set fileencoding=utf-8
%s/"/""/g
g/^\d\+$/d
%s#^\(.*\) --> \(.*\)\n#"\1","\2","#g
%s/\n^$/"/g
Variant to keep the sub numbering :
set fileencoding=utf-8
%s/"/""/g
%s#\(^\d\+\)$\n^\(.*\) --> \(.*\)\n#"\1","\2","\3","#g
%s/\n^$/"/g
Save this code into a text file with the .vim extension, then source this file when editing your .srt in Vim / Gvim. Save the result as a .csv. Enjoy the magic of Regexes !
NB : my code uses commas as field separators. Change the commas into semi-colons in the above code to use semi-colons. I've also added double-quotes as string delimitors in case double-quotes and commas occur in the subtitle text. Much more error proof !
So I have this home-made Excel Macro Template.
The task of the macro code that I inserted in my xlsm file is to Save a copy in the same folder with a different format. That format is .txt (see image below)
The expected result of the macro (after saving) should be the same with the excel file (visually) but this time it is in a .txt format.
Unfortunately, that didn't happened. It generates a different txt file and it contains unreadable alpha numeric characters, here's an example of the generated txt file.
¬TËNÃ0 ¼#ñ ‘¯(vဠjÚ # °µ· ©c[^SÚ¿g“–
P ö '±wfvìq 8o\1ÃD6øJœËž(Ðë`¬ŸTâõå¾¼ eð \ðX‰ ’ NOú/‹ˆTpµ§JÔ9Çk¥H×Ø É ÑóÌ8¤ 2 ¦‰Š §0AuÑë]* |FŸËÜbˆAÿ Çðîrq7çßK%#ëEq³\×RU btVCf¡jæ l¨ã±Õ(g#xJá
u j#XBG{Ð~J.Wr%WvŒTÛHgÜÓ †vf»ÜUÝ#ûœ¬Áâ R~€†›Rs§>BšŽB˜ÊÝ «žq®ÑIª ³l#§pçaä ý ë¿ î`ê*IuÃù ( ³´Ü ýÞð JŠ Át` “m'Ýû ™ ªîy¸„ f !å…C:r·KÐ}Ì5$4Ï9q Ž.à;ö. ¼] H ¼„ÿwá+mu S¶¸ŽÃ¦Ã¶fäÔ l;¶×‚A³ [u×Ðà ÿÿ PK ! µU0#ô L _rels/.rels ¢ (
Here's my macro code:
Sub SaveMe()
Dim FName As Range
Dim firstDate As String
Dim firstTime As String
Dim answer As Integer
firstDate = Format(Date, "mmddyyyy")
firstTime = Format(Now, "hhmmssAM/PM")
Set FName = Range("H5")
ActiveWorkbook.SaveCopyAs FileName:=ActiveWorkbook.Path & "\" & "QB JE " & FName & " " & firstDate & " " & firstTime & ".txt", FileFormat:=xlText, CreateBackup:=False
End Sub
I was wondering if anyone could take a look at my code and help to point out whats wrong.
It looks like you want the SaveAs Not the SaveCopyAs.
Fileformat xlText or xlTextMSDOS
You can two step the process. Save a copy, then open it, and save it as a text file.
ActiveWorkbook.SaveCopyAs FileName:=ActiveWorkbook.Path & "\" & "QB JE " & FName & " " & firstDate & " " & firstTime & ".xlsx"
Workbooks.Open (ActiveWorkbook.Path & "\" & "QB JE " & FName & " " & firstDate & " " & firstTime & ".xlsx")
ActiveWorkbook.SaveAs FileName:=ActiveWorkbook.Path & "\" & "QB JE " & FName & " " & firstDate & " " & firstTime & ".txt", FileFormat:=xlText, CreateBackup:=False
https://msdn.microsoft.com/en-us/library/office/ff841185.aspx
https://msdn.microsoft.com/en-us/library/office/ff198017.aspx
See from my post here. Excel VBA Export To Text File with Fixed Column Width + Specified Row and Columns Only + Transpose
Loop all rows and all cells. Send each value to a padspace function. Build the string from for each cells value with spaces padded after the cell value.
You will have to add a reference to you workbook. In the VBA IDE go to the tools pull down menu and select references. Then scroll down and select "Microsoft Scripting Runtime". Then hit OK.
Adjust the pad space function call argument to a number that fits the data that you have in your spreadsheet. So you will change the 20 in the line with the padspace call. PadSpace(20, len(cellValue))
This will do all rows and columns.
Public Sub MyMacro()
Dim lRow As Long
Dim lCol As Long
Dim strRow As String
Dim ws As Excel.Worksheet
Dim ts As TextStream
Dim fs As FileSystemObject
'Create the text file to write to
Set fs = New FileSystemObject
Set ts = fs.CreateTextFile("C:\Temp\test.txt", True, False)
Set ws = Application.ActiveSheet
'Loop through all the rows.
lRow = 1
Do While lRow <= ws.UsedRange.Rows.count
'Clear the string we are building
strRow = ""
'Loop through all the columns for the current row.
lCol = 1
Do While lCol <= ws.UsedRange.Columns.count
'Build a string to write out.
strRow = strRow & ws.Cells(lRow, lCol) & PadSpace(20, Len(ws.Cells(lRow, lCol)))
lCol = lCol + 1
Loop
'Write the line to the text file
ts.WriteLine strRow
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
ts.Close: Set ts = Nothing
Set fs = Nothing
End Sub
'This function will take the max number of spaces you want and the length of the string in the cell and return you the string of spaces to pad.
Public Function PadSpace(nMaxSpace As Integer, nNumSpace As Integer) As String
If nMaxSpace < nNumSpace Then
PadSpace = ""
Else
PadSpace = Space(nMaxSpace - nNumSpace)
End If
End Function
I have a folder with thousands of files, and a spreadsheet that has 2 pieces of information:
DocumentNumber Revision
00-STD-GE-1234-56 3
I need to find and concatenate all files in the folder than match this document number and revision combination into this format:
00-STD-GE-1234-56_3.docx|00-STD-GE-1234-56_3.pdf
The pdf must be last
sometimes the file is named without the last 3 chars of the document number (if they are -00 they are left off)
sometimes the revision is separated using "_" and sometimes using "_r"
I have the code working, but it takes a long time (this sheet has over 7000 rows, and this code is 20 file comparisons per row against a network file system), is there an optimization for this?
''=============================================================================
Enum IsFileOpenStatus
ExistsAndClosedOrReadOnly = 0
ExistsAndOpenSoBlocked = 1
NotExists = 2
End Enum
''=============================================================================
Function IsFileReadOnlyOpen(FileName As String) As IsFileOpenStatus
'ExistsAndClosedOrReadOnly = 0
'ExistsAndOpenSoBlocked = 1
'NotExists = 2
With New FileSystemObject
If Not .FileExists(FileName) Then
IsFileReadOnlyOpen = 2 ' NotExists = 2
Exit Function 'Or not - I don't know if you want to create the file or exit in that case.
End If
End With
Dim iFilenum As Long
Dim iErr As Long
On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0
Select Case iErr
Case 0: IsFileReadOnlyOpen = 0 'ExistsAndClosedOrReadOnly = 0
Case 70: IsFileReadOnlyOpen = 1 'ExistsAndOpenSoBlocked = 1
Case Else: IsFileReadOnlyOpen = 1 'Error iErr
End Select
End Function 'IsFileReadOnlyOpen
''=============================================================================
Function BuildAndCheckPath(sMasterPath As String, sLegacyDocNum As String, sRevision As String) As String
Dim sLegacyDocNumNoSheet As String
sLegacyDocNumNoSheet = Left(sLegacyDocNum, Len(sLegacyDocNum) - 3)
Dim sFileExtensions
sFileExtensions = Array(".doc", ".docx", ".xls", ".xlsx", ".pdf")
Dim sRevisionSpacer
sRevisionSpacer = Array("_", "_r")
Dim i As Long
Dim j As Long
Dim sResult As String
'for each revision spacer option
For i = LBound(sRevisionSpacer) To UBound(sRevisionSpacer)
'for each file extension
For j = LBound(sFileExtensions) To UBound(sFileExtensions)
'Check if the file exists (assume a sheet number i.e. 00-STD-GE-1234-56)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
If sResult = "" Then
sResult = sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
Else
sResult = sResult & "|" & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
End If
End If
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
If sResult = "" Then
sResult = sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
Else
sResult = sResult & "|" & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)
End If
End If
Next j
Next i
BuildAndCheckPath = sResult
End Function
It's hard to tell without seeing your dataset, but perhaps this approach could be implemented (note the use of Wildcards):
UNTESTED
Const Folder As String = "C:\YourFolder\"
Dim File as Object
Dim XLSFile As String
Dim PDFFile As String
Dim ConCat() As String
Dim DocNos() As Variant
Dim DocRev() As Variant
Dim i As Long
DocNos = Range("A1:A10") '<--Your list of Document #s.
DocRev = Range("B1:B10") '<--Your list of Revision #s.
ReDim ConCat(1 To UBound(DocNos))
'Loop through your Document numbers.
For i = LBound(DocNos) To UBound(DocNos)
'Loop through the folder.
File = Dir(Folder)
Do While File <> ""
'Check the filename against the Document number. Use a wildcard at this _
'point as a sort of "gatekeeper"
If File Like Left(DocNos(i), Len(DocNos(i)) - 3) & "*"
'If the code makes it to this point, you just need to match file _
'type and revision.
If File Like "*_*" & DocRev(i) And File Like "*.xls*" Then
XLSFile = File
ElseIf File Like "*_*" & DocRev(i) File Like "*.pdf" Then
PDFFile = File
End If
If XLSFile <> "" And PDFFile <> "" Then
ConCat(i) = XLSFile & "|" & PDFFile
XLSFile = vbNullString
PDFFile = vbNullString
End If
End If
File = Dir
Loop
Next i
To print the results to your sheet (Transpose pastes the results of the array in one column instead of putting the results in one row), you could use something like this:
Dim Rng As Range
Set Rng = Range("C1")
Rng.Resize(UBound(ConCat),1).Value = Application.Transpose(ConCat)
This approach loops through each document number from your spreadsheet, and then checks each file in the folder to see if it matches the document number, document type, and revision number. Once it finds a match for both .xls* and .pdf types, it concatenates the filenames together.
See this great SO post regarding looping through files.
See this site for more info about the Dir function.
See this article regarding wilcard character usage when comparing strings.
Hope that helps!
Seems to me you are doing unnecessary file existence checks even in cases where a file has already been found. Assuming that talking with your network drive is indeed what takes up most of your execution time, then there's a place to optimise.
What you're doing is this:
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
'...
End If
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
'Wait a minute... why ask me to look again if I already found it?
'He must not mind the extra waiting time... ok, here we go again.
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'...
End If
I think you want to look for your file under a different filename if and only if you haven't found it under the first filename pattern. Can do this using an Else clause:
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
Else
'Didn't find it using the first filename format.
'Do it again without a sheet number in the filename (last 3 digits stripped off legacy number)
If IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
Else
Err.Raise 53, , _
"File not found even though I looked for it in two places!"
End If
End If
This can theoretically cut your number of tries by up to half; likely less in practice, but you'll get the largest benefit if you check the most common filename pattern first. The benefit will be proportionally larger if you have a greater number of filename patterns; from your question I understand you have 4 different combinations?
If you have more than 2 patterns to check, then nesting a bunch of Else clauses will look silly and be difficult to read; instead you can do something like this:
Dim foundIt As Boolean
foundIt = False
If Not foundIt And IsFileReadOnlyOpen(sMasterPath & sLegacyDocNum & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
foundIt = True
End If
If Not foundIt And IsFileReadOnlyOpen(sMasterPath & sLegacyDocNumNoSheet & sRevisionSpacer(i) & sRevision & sFileExtensions(j)) <> 2 Then
'Great. Found it.
foundIt = True
End If
'...
'... check your other patterns here...
'...
If Not foundIt Then
Err.Raise 53, , _
"File not found even though I looked for it various places!"
End If
I need to output some results as a .csv file, that gets parsed later on by another process. In order to produce these results, I have a huge workbook containing all the macros and functions that I need.
Is it possible to "create" a separate .csv file from VBA?
Is it possible to use VBA features to write into it instead of just writing in a "raw textual" approach?
Is something like this what you want?
Option Explicit
Sub WriteFile()
Dim ColNum As Integer
Dim Line As String
Dim LineValues() As Variant
Dim OutputFileNum As Integer
Dim PathName As String
Dim RowNum As Integer
Dim SheetValues() As Variant
PathName = Application.ActiveWorkbook.Path
OutputFileNum = FreeFile
Open PathName & "\Test.csv" For Output Lock Write As #OutputFileNum
Print #OutputFileNum, "Field1" & "," & "Field2"
SheetValues = Sheets("Sheet1").Range("A1:H9").Value
ReDim LineValues(1 To 8)
For RowNum = 1 To 9
For ColNum = 1 To 8
LineValues(ColNum) = SheetValues(RowNum, ColNum)
Next
Line = Join(LineValues, ",")
Print #OutputFileNum, Line
Next
Close OutputFileNum
End Sub
Don't forget you will need to put quotes around any field containing a comma.
Tony's answer generally works but doesn't handle the case where your text contains commas or quotes. You may prefer to use Workbook.SaveAs method.
Here is an example if you want to save the content of the Sheet1 as a separated csv file.
Sub create_csv()
Dim FileName As String
Dim PathName As String
Dim ws As Worksheet
Set ws = ActiveWorkbook.Sheets("Sheet1")
FileName = "filename.csv"
PathName = Application.ActiveWorkbook.Path
ws.Copy
ActiveWorkbook.SaveAs FileName:=PathName & "\" & FileName, _
FileFormat:=xlCSV, CreateBackup:=False
End Sub
Imagine that your Sheet1 contains :
lorem ipsum
lore,m ips"um"
The output csv file will be :
lorem,ipsum
"lore,m","ips""um"""
You may write a macro like to save the current workbook (opened excel file) in CSV from VBA:
ActiveWorkbook.SaveAs Filename:="C:\Book1.csv", _
FileFormat:=xlCSVMSDOS, CreateBackup:=False
For those writing the CSV manually, you need to handle commas, double quotes and new lines.
e.g.
Sub WriteToCsv(Items() as String)
OutFile = FreeFile
Open "Outfile.csv" For Output As #OutFile
Print #OutFile, "Header"
For Each Item In Items
If InStr(1, Item, Chr(34)) > 0 Then Item = Chr(34) & Replace(Item, Chr(34), Chr(34) & Chr(34)) & Chr(34)
If InStr(1, Item, ",") > 0 And Left(Item, 1) <> Chr(34) Then Item = Chr(34) & Item & Chr(34)
If InStr(1, Item, vbLf) > 0 And Left(Item, 1) <> Chr(34) Then Item = Chr(34) & Item & Chr(34)
Print #OutFile, Item
Next
Close OutFile
End Sub
Took your code as a basis (THANKS!!!) but had to modify it to make it work.
It didn't handle multiple rows, all cells were put after each other.
2 loops: one to go through the rows and one to go through the cells of each row.
Each time the row loop starts the temporary string is emptied. Before starting a new row, the temp string is added to the Outfile.
Sub ToCsv()
Dim rng As Range
Dim row As Range
Dim cell As Range
Dim ItemNew As String
Set rng = Range("A1:E2") 'Adjust the range accordingly
OutFile = FreeFile
Open "Outfile.csv" For Output As #OutFile
'Print #OutFile, "Header"
For Each row In rng.Rows
ItemNew = ""
For Each Item In row.Cells
If InStr(1, Item, Chr(34)) > 0 Then Item = Chr(34) & Replace(Item, Chr(34), Chr(34) & Chr(34)) & Chr(34)
If InStr(1, Item, ",") > 0 And Left(Item, 1) <> Chr(34) Then Item = Chr(34) & Item & Chr(34)
If InStr(1, Item, vbLf) > 0 And Left(Item, 1) <> Chr(34) Then Item = Chr(34) & Item & Chr(34)
If ItemNew = "" Then
ItemNew = Item
Else
ItemNew = ItemNew & "," & Item
End If
Next
Print #OutFile, ItemNew
Next
Close OutFile
End Sub