How to create a separate CSV file from VBA? - vba

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

Related

Find and Replace text with tabs and line breaks in VBA

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.

VBA code:Save the fillter data to txt file

VBA code: help me with, I want to save the fillter data to txt file.
Sub Intemp()
Dim arr, i As Long
Dim FPath As String
FPath = ThisWorkbook.Path & "\" & "text" & ".txt"
Application.CutCopyMode = False
arr = Sheet5.Range("B1:C" & [B100000].End(xlUp).Row)
Open FPath For Output As #1
For i = 1 To UBound(arr)
Print #1, arr(i, 1) & vbTab & arr(i, 2)
Next i
Close #1
End Sub
If you want to assign your filtered values to an array, an easy way to do that would be to use advanced filtering and filter into another area of the worksheet and assign your values there.
But a simple approach that will get you started is to just loop your rows in your range, if the row is hidden, then move on - otherwise, print the data to your text document.
Dim rng As Range, r As Long
Set rng = Sheet5.Range("B1:C" & [B100000].End(xlUp).Row)
Dim FPath As String
FPath = ThisWorkbook.Path & "\" & "text" & ".txt"
Application.CutCopyMode = False
Open FPath For Output As #1
With Sheet5
For r = rng.Row To rng.Rows.Count + rng.Row - 1
If Not .Rows(r).Hidden Then
Print #1, .Cells(r, 1) & vbTab & .Cells(r, 2)
End If
Next
End With
Close #1

Removing White Space

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.

Correct Excel Macro to Save A Copy Excel File as TXT or CSV

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

Is there a better way to check if files exist using Excel VBA

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